home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / boxer / boxer.lha / disply.lisp < prev    next >
Encoding:
Text File  |  1993-07-17  |  55.1 KB  |  1,444 lines
  1. ;; -*- Mode:LISP; Package:(BOXER GLOBAL 1000); Base: 8.; Fonts: CPTFONT,CPTFONTI -*-
  2.  
  3. ;; (C) Copyright 1983-1985 Massachusetts Institute of Technology
  4. ;;
  5. ;; Permission to use, copy, modify, distribute, and sell this software
  6. ;; and its documentation for any purpose is hereby granted without fee,
  7. ;; provided that the above copyright notice appear in all copies and that
  8. ;; both that copyright notice and this permission notice appear in
  9. ;; supporting documentation, and that the name of M.I.T. not be used in
  10. ;; advertising or publicity pertaining to distribution of the software
  11. ;; without specific, written prior permission.  M.I.T. makes no
  12. ;; representations about the suitability of this software for any
  13. ;; purpose.  It is provided "as is" without express or implied warranty.
  14. ;;
  15.  
  16. ;;;this file contains random code having to do with screen structure
  17. ;;;such as allocation/deallocation code, mouse tracking stuff and box
  18. ;;;border functions
  19.  
  20. ;;;All of the high level redisplay code is in the file REDISP and
  21. ;;;the low level code for accessing and patching up screen structure is
  22. ;;;to be found in the file LODISP
  23.  
  24. ;;;; LOW-LEVEL SCREEN-OBJ allocation/deallocation code.
  25.  
  26. ;;; Use our own resource allocation/deallocation scheme here because the
  27. ;;; Lispm's DEALLOCATE-RESOURCE is so slow that it significantly slows
  28. ;;; down the whole redisplay code.
  29.  
  30. (DEFUN SETUP-REDISPLAY ()
  31.   (SETQ FREE-SCREEN-ROWS NIL
  32.     FREE-SCREEN-BOXS NIL
  33.     FREE-GRAPHICS-SCREEN-BOXS NIL)
  34.   (DOTIMES (I INITIAL-NO-OF-FREE-SCREEN-ROWS)
  35.     (PUSH (MAKE-INSTANCE 'SCREEN-ROW) FREE-SCREEN-ROWS))
  36.   (DOTIMES (I INITIAL-NO-OF-FREE-SCREEN-BOXS)
  37.     (PUSH (MAKE-INSTANCE 'SCREEN-BOX) FREE-SCREEN-BOXS))
  38.   (DOTIMES (I INITIAL-NO-OF-FREE-GRAPHICS-SCREEN-BOXS)
  39.     (PUSH (MAKE-INSTANCE 'GRAPHICS-SCREEN-BOX) FREE-GRAPHICS-SCREEN-BOXS)))
  40.  
  41. (DEFMETHOD (SCREEN-BOX :RE-INIT) (NEW-ACTUAL-OBJ)
  42.   (SETQ ACTUAL-OBJ NEW-ACTUAL-OBJ
  43.     WID 0
  44.     HEI 0
  45.     X-GOT-CLIPPED? NIL
  46.     Y-GOT-CLIPPED? NIL
  47.     TICK -1
  48.     NEEDS-REDISPLAY-PASS-2? NIL
  49.     FORCE-REDISPLAY-INFS? NIL
  50.     SCREEN-ROWS NIL
  51.     SCREEN-ROW NIL
  52.     BPS NIL))
  53.  
  54. (DEFMETHOD (SCREEN-ROW :RE-INIT) (NEW-ACTUAL-OBJ)
  55.   (SETQ ACTUAL-OBJ NEW-ACTUAL-OBJ
  56.     WID 0
  57.     HEI 0
  58.     X-GOT-CLIPPED? NIL
  59.     Y-GOT-CLIPPED? NIL
  60.     TICK -1
  61.     NEEDS-REDISPLAY-PASS-2? NIL
  62.     FORCE-REDISPLAY-INFS? #+3600 T #-3600 NIL))
  63.  
  64.  (DEFMETHOD (SCREEN-ROW :AFTER :RE-INIT) (IGNORE)
  65.   (SETQ SCREEN-CHAS NIL
  66.     SCREEN-BOX NIL))
  67.  
  68. (DEFMETHOD (SCREEN-BOX :AFTER :RE-INIT) (NEW-ACTUAL-BOX)
  69.   (TELL SELF :SET-BOX-TYPE (TELL NEW-ACTUAL-BOX :TYPE)))
  70.  
  71.  
  72.  
  73.  
  74. ;;;; HIGH-LEVEL SCREEN-OBJ allocation/deallocation code.
  75.  
  76. ;;; This code is responsible for allocating screen-objs to represent actual
  77. ;;; objs. This code isn't terribly complicated, but it is basic to the rest
  78. ;;; of the display code, so it is probably a good idea to understand how it
  79. ;;; works. So, listen carefully... This code is based on the following basic
  80. ;;; assumptions:
  81. ;;;  
  82. ;;;   No actual object can be displayed more than once at any
  83. ;;;    "level". For example, the same box cannot be displayed
  84. ;;;    right next to itself. On the other hand a port to a box
  85. ;;;    can be displayed right next to the box since the lispm
  86. ;;;    port object is neq to the lispm box object.
  87. ;;;
  88. ;;;   That whenever moving of actual objs is implemented (this
  89. ;;;;   includes boxing and unboxing operations) redisplay clues
  90. ;;;    which tell what happened will be added and this code will
  91. ;;;    be updated to take these clues into account.
  92. ;;;
  93. ;;; Given these assumptions, and given that:
  94. ;;;    ACTUAL-OBJ
  95. ;;;        is an actual obj to be displayed (a screen-obj is
  96. ;;;        needed in order to display it)
  97. ;;;    SUPERIOR-SCREEN-BOX
  98. ;;;        is the screen-box in which the actual obj is going
  99. ;;;        to be displayed
  100. ;;;    SCREEN-OBJ
  101. ;;;        is the screen-obj which represents the actual obj
  102. ;;;        when it is displayed in that particular superior
  103. ;;;        screen-box
  104. ;;; Then:
  105. ;;;
  106. ;;;     (ACTUAL-OBJ , SUPERIOR-SCREEN-OBJ)  SCREEN-OBJ
  107. ;;;
  108. ;;; The :ALLOCATE-SCREEN-OBJ-FOR-USE-IN method uses this mapping to allocate
  109. ;;; screen-objs to represent actual objs. Calling this method is the only
  110. ;;; correct way to get screen-objs which represent actual objs.
  111.  
  112. (DEFMETHOD (ACTUAL-OBJ-MIXIN :ALLOCATE-SCREEN-OBJ-FOR-USE-IN) (USE-IN-SCREEN-BOX)
  113.   (LET ((EXISTING-SCREEN-OBJ (ASSQ USE-IN-SCREEN-BOX SCREEN-OBJS)))
  114.     (IF (NOT-NULL EXISTING-SCREEN-OBJ)
  115.     (CDR EXISTING-SCREEN-OBJ)
  116.     (LET ((NEW-SCREEN-OBJ (ALLOCATE-SCREEN-OBJ-INTERNAL SELF)))
  117.       (PUSH (CONS USE-IN-SCREEN-BOX NEW-SCREEN-OBJ) SCREEN-OBJS)
  118.       (WHEN (SCREEN-BOX? NEW-SCREEN-OBJ)
  119.         (TELL NEW-SCREEN-OBJ :SET-SUPERIOR-SCREEN-BOX USE-IN-SCREEN-BOX)
  120.         (TELL NEW-SCREEN-OBJ :SET-NAME
  121.           (TELL-CHECK-NIL (TELL SELF :NAME-ROW) :TEXT-STRING)))
  122.       NEW-SCREEN-OBJ))))
  123.  
  124. (DEFUN ALLOCATE-SCREEN-SHEET-FOR-USE-IN (GRAPHICS-SHEET USE-IN-SCREEN-BOX)
  125.   (LET* ((SCREEN-OBJS (GRAPHICS-SHEET-SCREEN-OBJS GRAPHICS-SHEET))
  126.      (EXISTING-SCREEN-OBJ (ASSQ USE-IN-SCREEN-BOX SCREEN-OBJS)))
  127.     (IF (NOT-NULL EXISTING-SCREEN-OBJ)
  128.     (CDR EXISTING-SCREEN-OBJ)
  129.     (LET ((NEW-SCREEN-OBJ (ALLOCATE-SCREEN-OBJ-INTERNAL GRAPHICS-SHEET)))
  130.       (SETF (GRAPHICS-SHEET-SCREEN-OBJS GRAPHICS-SHEET)
  131.         (PUSH (CONS USE-IN-SCREEN-BOX NEW-SCREEN-OBJ) SCREEN-OBJS))
  132.       NEW-SCREEN-OBJ))))
  133.  
  134. (DEFUN SCREEN-STRUCTURE-ACTUAL-SUPERIOR-BOX (SCREEN-BOX)
  135.   (LET ((SUPERIOR-SCREEN-BOX (TELL SCREEN-BOX :SUPERIOR-SCREEN-BOX)))
  136.     (WHEN (SCREEN-BOX? SUPERIOR-SCREEN-BOX)
  137.       (TELL SUPERIOR-SCREEN-BOX :ACTUAL-OBJ))))
  138.  
  139. (defmethod (actual-obj-mixin :allocate-outermost-screen-box-for-use-in)
  140.        (window &OPTIONAL (SCREEN-BOX (BP-SCREEN-BOX *POINT*)))
  141.   (let ((actual-superior-box (SCREEN-STRUCTURE-ACTUAL-SUPERIOR-BOX SCREEN-BOX)))
  142.     (tell self                    
  143.       :allocate-screen-obj-for-use-in
  144.       (if actual-superior-box
  145.           (tell actual-superior-box
  146.             :allocate-outermost-screen-box-for-use-in window
  147.             (TELL SCREEN-BOX :SUPERIOR-SCREEN-BOX))
  148.           window))))
  149.  
  150. (DEFMETHOD (ACTUAL-OBJ-MIXIN :SCREEN-OBJS) ()
  151.   (MAPCAR #'CDR SCREEN-OBJS))
  152.  
  153. ;;; Whenever any section of code is done with a screen-obj which they got by
  154. ;;; calling :allocate-screen-obj-for-use-in they should deallocate that screen-
  155. ;;; obj by sending it a deallocate-self message. If there are no more users
  156. ;;; of that screen-obj, it will be returned to the pool of free screen-objs
  157. ;;; of that type.
  158.  
  159. (DEFWHOPPER (SCREEN-OBJ :DEALLOCATE-SELF) ()
  160.   (WHEN (NULL (TELL SELF :SUPERIOR))
  161.     (CONTINUE-WHOPPER)))
  162.  
  163. (DEFMETHOD (SCREEN-ROW :DEALLOCATE-SELF) ()
  164.   (TELL SELF :DEALLOCATE-INFERIORS)
  165.   (TELL ACTUAL-OBJ :DELETE-SCREEN-OBJ SELF)
  166.   (DEALLOCATE-SCREEN-OBJ-INTERNAL SELF))
  167.  
  168. (DEFMETHOD (SCREEN-BOX :DEALLOCATE-SELF) ()
  169.   (TELL SELF :DEALLOCATE-INFERIORS))
  170.  
  171. (DEFMETHOD (GRAPHICS-SCREEN-BOX :DEALLOCATE-SELF) ()
  172.   ;; shadow out the message here since we are not running resources on GRAPHICS-SCREEN-SHEET's
  173.   NIL)
  174.                         
  175. (DEFMETHOD (SCREEN-BOX :DEALLOCATE-INFERIORS) ()
  176.   (LET ((INFERIORS (TELL SELF :INFERIORS)))
  177.     (WHEN (#+SYMBOLICS LISTP #-SYMBOLICS CONSP INFERIORS)
  178.       (TELL SELF :KILL-SCREEN-OBJ (CAR INFERIORS))
  179.       (DOLIST (INFERIOR INFERIORS)
  180.     (TELL INFERIOR :DEALLOCATE-SELF)))))
  181.  
  182. (DEFMETHOD (SCREEN-ROW :DEALLOCATE-INFERIORS) ()
  183.   (LET ((INFERIOR-BOXES (EXTRACT-SCREEN-BOXES (TELL SELF :INFERIORS))))
  184.     (WHEN (NOT-NULL INFERIOR-BOXES)
  185.       (TELL SELF :KILL-SCREEN-OBJ (CAR INFERIOR-BOXES))
  186.       (DOLIST (INFERIOR INFERIOR-BOXES)
  187.     (TELL INFERIOR :DEALLOCATE-SELF)))))
  188.  
  189. (DEFMETHOD (ACTUAL-OBJ-MIXIN :DELETE-SCREEN-OBJ) (SCREEN-OBJ)
  190.   (SETQ SCREEN-OBJS (DELETE (RASSQ SCREEN-OBJ SCREEN-OBJS) SCREEN-OBJS)))
  191.  
  192. (DEFUN QUEUE-SCREEN-OBJ-FOR-DEALLOCATION (SCREEN-OBJ)
  193.   (LOCAL-DECLARE ((SPECIAL SCREEN-OBJS-DEALLOCATION-QUEUE))
  194.     (SPLICE-ITEM-ONTO-LIST SCREEN-OBJS-DEALLOCATION-QUEUE SCREEN-OBJ)))
  195.  
  196. (DEFUN QUEUE-SCREEN-OBJS-FOR-DEALLOCATION (SCREEN-OBJS)
  197.   (LOCAL-DECLARE ((SPECIAL SCREEN-OBJS-DEALLOCATION-QUEUE))
  198.     (SPLICE-LIST-ONTO-LIST SCREEN-OBJS-DEALLOCATION-QUEUE SCREEN-OBJS)))
  199.  
  200.  
  201.  
  202. (DEFUN SCREEN-OBJ-OFFSETS (SCREEN-OBJ)
  203.   (VALUES (SCREEN-OBJ-X-OFFSET SCREEN-OBJ)
  204.       (SCREEN-OBJ-Y-OFFSET SCREEN-OBJ)))
  205.  
  206. (DEFUN SET-SCREEN-OBJ-OFFSETS (SCREEN-OBJ NEW-X-OFFSET NEW-Y-OFFSET)
  207.   (SETF (SCREEN-OBJ-X-OFFSET SCREEN-OBJ) NEW-X-OFFSET)
  208.   (SETF (SCREEN-OBJ-Y-OFFSET SCREEN-OBJ) NEW-Y-OFFSET))
  209.  
  210. (DEFUN SCREEN-OBJ-SIZE (SCREEN-OBJ)
  211.   (VALUES (SCREEN-OBJ-WID SCREEN-OBJ)
  212.       (SCREEN-OBJ-HEI SCREEN-OBJ)))
  213.  
  214. (DEFUN SCREEN-OBJS-SIZE (SCREEN-OBJS &AUX (WID 0) (HEI 0))
  215.   (COND ((SCREEN-CHA? (CAR SCREEN-OBJS))
  216.      (DOLIST (SCREEN-CHA SCREEN-OBJS)
  217.        (SETQ WID (+ WID (SCREEN-OBJ-WID SCREEN-CHA))
  218.          HEI (MAX HEI (SCREEN-OBJ-HEI SCREEN-CHA)))))
  219.     (T
  220.      (DOLIST (SCREEN-ROW SCREEN-OBJS)
  221.        (SETQ WID (MAX WID (SCREEN-OBJ-WID SCREEN-ROW))
  222.          HEI (+ HEI (SCREEN-OBJ-HEI SCREEN-ROW))))))
  223.   (VALUES WID HEI))
  224.  
  225. (DEFUN SCREEN-BOXES-AND-WHITESPACE-SIZE (SCREEN-BOXES &AUX(WID 0) (HEI 0))
  226.   (LET ((FIRST-BOX (CAR SCREEN-BOXES))
  227.     (LAST-BOX (CAR (LAST SCREEN-BOXES))))
  228.     (SETQ WID (- (+ (SCREEN-OBJ-X-OFFSET LAST-BOX) (SCREEN-OBJ-WID LAST-BOX))
  229.          (SCREEN-OBJ-X-OFFSET FIRST-BOX)))
  230.     (DOLIST (SCREEN-BOX SCREEN-BOXES)
  231.       (SETQ HEI (MAX (SCREEN-OBJ-HEI SCREEN-BOX) HEI)))
  232.     (VALUES WID HEI)))
  233.  
  234. (DEFUN SCREEN-OBJS-WID (SCREEN-OBJS)
  235.   (MULTIPLE-VALUE-BIND (WID NIL) (SCREEN-OBJS-SIZE SCREEN-OBJS) WID))
  236.  
  237. (DEFUN SCREEN-OBJS-HEI (SCREEN-OBJS)
  238.   (MULTIPLE-VALUE-BIND (NIL HEI) (SCREEN-OBJS-SIZE SCREEN-OBJS) HEI))
  239.  
  240. (DEFUN SCREEN-OBJS-NEXT-SCREEN-OBJ-DELTA-OFFSETS-WHEN-ERASED (SCREEN-OBJS)
  241.   (IF (SCREEN-CHA? (CAR SCREEN-OBJS))
  242.       (VALUES (SCREEN-OBJS-WID SCREEN-OBJS) 0)
  243.       (VALUES 0 (SCREEN-OBJS-HEI SCREEN-OBJS))))
  244.  
  245.  
  246. (DEFUN MAP-OVER-SCREEN-OBJ (SCREEN-OBJ FN)
  247.   (FUNCALL FN SCREEN-OBJ)
  248.   (MAP-OVER-SCREEN-OBJS (TELL SCREEN-OBJ :INFERIORS) FN))
  249.  
  250. (DEFUN MAP-OVER-SCREEN-OBJS (LIST-OF-SCREEN-OBJS FN)
  251.   (DOLIST (SCREEN-OBJ LIST-OF-SCREEN-OBJS)
  252.     (MAP-OVER-SCREEN-OBJ SCREEN-OBJ FN)))
  253.  
  254.  
  255. (DEFUN SCREEN-OBJ-ZERO-SIZE (SCREEN-OBJ)
  256.   (SETF (SCREEN-OBJ-WID SCREEN-OBJ) 0)
  257.   (SETF (SCREEN-OBJ-HEI SCREEN-OBJ) 0))
  258.  
  259. (DEFUN ERASE-SCREEN-CHA (SCREEN-CHA X-OFFSET Y-OFFSET)
  260.   (IF (NOT-NULL SCREEN-CHA)
  261.     (LET ((WID (CHA-WIDTH SCREEN-CHA))
  262.       (HEI (CHA-HEI (FONT-NO SCREEN-CHA))))
  263.       (DRAW-RECTANGLE TV:ALU-ANDCA WID HEI X-OFFSET Y-OFFSET))
  264.     (FERROR "null screen-cha for some reason")))
  265.  
  266. (DEFUN ERASE-SCREEN-BOX (SCREEN-BOX X-OFFSET Y-OFFSET)
  267.   (MULTIPLE-VALUE-BIND (WID HEI)
  268.       (SCREEN-OBJ-SIZE SCREEN-BOX)
  269.     (DRAW-RECTANGLE TV:ALU-ANDCA WID HEI X-OFFSET Y-OFFSET))
  270.   (SCREEN-OBJ-ZERO-SIZE SCREEN-BOX)
  271.   (TELL SCREEN-BOX :SET-NEEDS-REDISPLAY-PASS-2? T)
  272.   (TELL SCREEN-BOX :SET-FORCE-REDISPLAY-INFS? T))
  273.  
  274.  
  275. (DEFUN SCREEN-OBJECT-WIDTH (SCREEN-OBJECT)
  276.   (when screen-object
  277.     (IF (SCREEN-CHA? SCREEN-OBJECT)
  278.     (CHA-WIDTH SCREEN-OBJECT)
  279.     (SCREEN-OBJ-WID SCREEN-OBJECT))))
  280.  
  281. (DEFUN SCREEN-OBJECT-NEW-WIDTH (SCREEN-OBJECT)
  282.   (when screen-object
  283.     (IF (SCREEN-CHA? SCREEN-OBJECT)
  284.     (CHA-WIDTH SCREEN-OBJECT)
  285.     (SCREEN-OBJ-NEW-WID SCREEN-OBJECT))))
  286.  
  287. (DEFUN-METHOD ERASE-CHAS-TO-EOL SCREEN-ROW (CHA-NO STARTING-X-OFFSET STARTING-Y-OFFSET)
  288.   (LET ((CHAS (GATHER-SCREEN-CHAS CHA-NO (LENGTH SCREEN-CHAS)))
  289.     (CURRENT-X-OFFSET STARTING-X-OFFSET)
  290.     (CURRENT-Y-OFFSET STARTING-Y-OFFSET))
  291.     (DO* ((CHAS-LEFT CHAS (CDR CHAS-LEFT))
  292.       (CHA-TO-ERASE (CAR CHAS-LEFT) (CAR CHAS-LEFT)))
  293.      ((NULL CHA-TO-ERASE))
  294.       (WHEN (SCREEN-CHA? CHA-TO-ERASE)
  295.     (ERASE-SCREEN-CHA CHA-TO-ERASE CURRENT-X-OFFSET CURRENT-Y-OFFSET))
  296.       (SETQ CURRENT-X-OFFSET (+ CURRENT-X-OFFSET (SCREEN-OBJECT-WIDTH CHA-TO-ERASE))))))
  297.  
  298. (DEFUN ERASE-SCREEN-CHAS (CHAS STARTING-X-OFFSET STARTING-Y-OFFSET)
  299.   (LET ((CURRENT-X-OFFSET STARTING-X-OFFSET)
  300.     (CURRENT-Y-OFFSET STARTING-Y-OFFSET))
  301.     (DO* ((CHAS-LEFT CHAS (CDR CHAS-LEFT))
  302.       (CHA-TO-ERASE (CAR CHAS-LEFT) (CAR CHAS-LEFT))
  303.       (x-incrementer (SCREEN-OBJECT-WIDTH CHA-TO-ERASE)
  304.              (SCREEN-OBJECT-WIDTH CHA-TO-ERASE)))
  305.      ((NULL CHA-TO-ERASE))
  306.       (IF (SCREEN-CHA? CHA-TO-ERASE)
  307.       (ERASE-SCREEN-CHA CHA-TO-ERASE CURRENT-X-OFFSET CURRENT-Y-OFFSET)
  308.       (ERASE-SCREEN-BOX CHA-TO-ERASE CURRENT-X-OFFSET CURRENT-Y-OFFSET))
  309.       (SETQ CURRENT-X-OFFSET (+ CURRENT-X-OFFSET x-incrementer)))))
  310.     
  311. (DEFUN ERASE-SCREEN-OBJ (SCREEN-OBJ)
  312.   (WHEN (NOT-NULL SCREEN-OBJ)
  313.     (CHECK-SCREEN-OBJ-ARG SCREEN-OBJ)
  314.     (MULTIPLE-VALUE-BIND (WID HEI)
  315.     (SCREEN-OBJ-SIZE SCREEN-OBJ)
  316.       (MULTIPLE-VALUE-BIND (X-OFFSET Y-OFFSET)
  317.       (SCREEN-OBJ-OFFSETS SCREEN-OBJ)
  318.     (DRAW-RECTANGLE TV:ALU-ANDCA WID HEI X-OFFSET Y-OFFSET)
  319.     (SCREEN-OBJ-ZERO-SIZE SCREEN-OBJ)
  320.     (TELL SCREEN-OBJ :SET-NEEDS-REDISPLAY-PASS-2? T)
  321.     (TELL SCREEN-OBJ :SET-FORCE-REDISPLAY-INFS? T)))))
  322.  
  323. (DEFUN ERASE-SCREEN-OBJS (SCREEN-OBJS)
  324.   (WHEN (NOT-NULL SCREEN-OBJS)
  325.     (CHECK-SCREEN-OBJ-ARG (FIRST SCREEN-OBJS))
  326.     (MULTIPLE-VALUE-BIND (WID HEI)
  327.     (SCREEN-OBJS-SIZE SCREEN-OBJS)
  328.       (MULTIPLE-VALUE-BIND (X-OFFSET Y-OFFSET)
  329.       (SCREEN-OBJ-OFFSETS (CAR SCREEN-OBJS))
  330.     (DRAW-RECTANGLE TV:ALU-ANDCA WID HEI X-OFFSET Y-OFFSET)
  331.     (DOLIST (SCREEN-OBJ SCREEN-OBJS)
  332.       (SCREEN-OBJ-ZERO-SIZE SCREEN-OBJ)
  333.       (TELL SCREEN-OBJ :SET-NEEDS-REDISPLAY-PASS-2? T)
  334.       (TELL SCREEN-OBJ :SET-FORCE-REDISPLAY-INFS? T))))))
  335.       
  336. (DEFUN MOVE-SCREEN-BOXES (SCREEN-BOXES DELTA-X DELTA-Y)
  337.   (WHEN (NOT-NULL SCREEN-BOXES)
  338.     (CHECK-SCREEN-BOX-ARG (FIRST SCREEN-BOXES))
  339.     (MULTIPLE-VALUE-BIND (WID HEI)
  340.     (SCREEN-BOXES-AND-WHITESPACE-SIZE SCREEN-BOXES)
  341.       (MULTIPLE-VALUE-BIND (X-OFFSET Y-OFFSET)
  342.       (SCREEN-OBJ-OFFSETS (CAR SCREEN-BOXES))
  343.     (BITBLT-MOVE-REGION WID HEI X-OFFSET Y-OFFSET DELTA-X DELTA-Y)
  344.     (DOLIST (SCREEN-BOX SCREEN-BOXES)
  345.       (INCF (SCREEN-OBJ-X-OFFSET SCREEN-BOX) DELTA-X)
  346.       (INCF (SCREEN-OBJ-Y-OFFSET SCREEN-BOX) DELTA-Y))))))
  347.  
  348. (DEFUN MOVE-SCREEN-OBJ (SCREEN-OBJ DELTA-X DELTA-Y)
  349.   (WHEN (NOT-NULL SCREEN-OBJ)
  350.     (CHECK-SCREEN-OBJ-ARG SCREEN-OBJ)
  351.     (MULTIPLE-VALUE-BIND (WID HEI)
  352.     (SCREEN-OBJ-SIZE SCREEN-OBJ)
  353.       (MULTIPLE-VALUE-BIND (X-OFFSET Y-OFFSET)
  354.       (SCREEN-OBJ-OFFSETS SCREEN-OBJ)
  355.     (BITBLT-MOVE-REGION WID HEI X-OFFSET Y-OFFSET DELTA-X DELTA-Y)
  356.     (INCF (SCREEN-OBJ-X-OFFSET SCREEN-OBJ) DELTA-X)
  357.     (INCF (SCREEN-OBJ-Y-OFFSET SCREEN-OBJ) DELTA-Y)))))
  358.  
  359. (DEFUN MOVE-SCREEN-OBJS (SCREEN-OBJS DELTA-X DELTA-Y)
  360.   (WHEN (NOT-NULL SCREEN-OBJS)
  361.     (CHECK-SCREEN-OBJ-ARG (FIRST SCREEN-OBJS))
  362.     (MULTIPLE-VALUE-BIND (WID HEI)
  363.     (SCREEN-OBJS-SIZE SCREEN-OBJS)
  364.       (MULTIPLE-VALUE-BIND (X-OFFSET Y-OFFSET)
  365.       (SCREEN-OBJ-OFFSETS (CAR SCREEN-OBJS))
  366.     (BITBLT-MOVE-REGION WID HEI X-OFFSET Y-OFFSET DELTA-X DELTA-Y)
  367.     (DOLIST (SCREEN-OBJ SCREEN-OBJS)
  368.       (INCF (SCREEN-OBJ-X-OFFSET SCREEN-OBJ) DELTA-X)
  369.       (INCF (SCREEN-OBJ-Y-OFFSET SCREEN-OBJ) DELTA-Y))))))
  370.  
  371. (DEFUN MOVE-GRAPHICS-SHEET (GRAPHICS-SCREEN-SHEET DELTA-X DELTA-Y)
  372.   (WHEN (NOT-NULL GRAPHICS-SCREEN-SHEET)
  373.     (CHECK-GRAPHICS-SCREEN-SHEET-ARG GRAPHICS-SCREEN-SHEET)
  374.     (LET* ((GRAPHICS-SHEET (GRAPHICS-SCREEN-SHEET-ACTUAL-OBJ GRAPHICS-SCREEN-SHEET))
  375.        (WID (GRAPHICS-SHEET-DRAW-WID GRAPHICS-SHEET))
  376.        (HEI (GRAPHICS-SHEET-DRAW-HEI GRAPHICS-SHEET))
  377.        (X-OFFSET (GRAPHICS-SCREEN-SHEET-X-OFFSET GRAPHICS-SCREEN-SHEET))
  378.        (Y-OFFSET (GRAPHICS-SCREEN-SHEET-Y-OFFSET GRAPHICS-SCREEN-SHEET)))
  379.       (BITBLT-MOVE-REGION WID HEI X-OFFSET Y-OFFSET DELTA-X DELTA-Y)
  380.       (INCF (GRAPHICS-SCREEN-SHEET-X-OFFSET GRAPHICS-SCREEN-SHEET) DELTA-X)
  381.       (INCF (GRAPHICS-SCREEN-SHEET-Y-OFFSET GRAPHICS-SCREEN-SHEET) DELTA-Y))))
  382.  
  383. (DEFUN MOVE-INFERIOR-SCREEN-OBJS (INFERIORS DELTA-X DELTA-Y)
  384.   (COND ((NULL INFERIORS))
  385.     ((GRAPHICS-SCREEN-SHEET? INFERIORS)
  386.      (MOVE-GRAPHICS-SHEET INFERIORS DELTA-X DELTA-Y))
  387.     ((AND (LISTP INFERIORS) (SCREEN-OBJ? (CAR INFERIORS)))
  388.      (MOVE-SCREEN-OBJS INFERIORS DELTA-X DELTA-Y))
  389.     ((SCREEN-OBJ? INFERIORS)
  390.      (MOVE-SCREEN-OBJ INFERIORS DELTA-X DELTA-Y))
  391.        (T
  392.     (FERROR "Don't know how to move inferior screen object(s), ~S" INFERIORS))))
  393.      
  394. (DEFUN GRAY-SIZE-AND-OFFSETS (SCREEN-BOX)
  395.   (MULTIPLE-VALUE-BIND (OUTER-WID OUTER-HEI)
  396.       (SCREEN-BOX-BORDERS-FN ':MINIMUM-SIZE SCREEN-BOX)
  397.     (MULTIPLE-VALUE-BIND (IL IT IR IB)
  398.     (SCREEN-BOX-BORDERS-FN ':BORDER-WIDS SCREEN-BOX)
  399.       (VALUES (- OUTER-WID IL IR) (- OUTER-HEI IT IB) IL IT))))
  400.  
  401. (DEFUN MOVE-GRAY-REGION (SCREEN-BOX DELTA-X DELTA-Y)
  402.   (MULTIPLE-VALUE-BIND (GRAY-WID GRAY-HEI GRAY-X GRAY-Y)
  403.       (GRAY-SIZE-AND-OFFSETS SCREEN-BOX)
  404.     (BITBLT-MOVE-REGION GRAY-WID GRAY-HEI GRAY-X GRAY-Y DELTA-X DELTA-Y)))
  405.  
  406.  
  407. ;:SHRUNK   USE *SHRUNK-BOX-WID* AND *SHRUNK-BOX-HEI*
  408. ;:NORMAL  IF ACTUAL-BOX HAS FIXED-SIZE USE IT OTHERWISE USE OTHER CONSTRAINT
  409. ;:OUTERMOST USE OUTERMOST-SIZE
  410.  
  411. ;; Note that with name tabs on the sides of boxes we have to make sure that the fixed size
  412. ;; refers to the part of the box with actual contents in it rather than the size of the entire
  413. ;; box label included
  414.  
  415. (DEFGET-METHOD (BOX :DISPLAY-STYLE-LIST) DISPLAY-STYLE-LIST)
  416. (DEFSET-METHOD (BOX :SET-DISPLAY-STYLE-LIST) DISPLAY-STYLE-LIST)
  417.  
  418. (DEFGET-METHOD (SCREEN-BOX :DISPLAY-STYLE-LIST) DISPLAY-STYLE-LIST)
  419. (DEFSET-METHOD (SCREEN-BOX :SET-DISPLAY-STYLE-LIST) DISPLAY-STYLE-LIST)
  420.  
  421. (DEFMETHOD (BOX :DISPLAY-STYLE) ()
  422.   (CAR DISPLAY-STYLE-LIST))
  423.  
  424. ;;; 1IMPORTANT.  The numbers returned by the various0 FIXED-SIZE1 methods refer to the size that
  425. 0;;; 1the0 INFERIORS1 want to be and NOT the size of the entire box since the size of the0 NAME
  426. ;;; 1can change
  427.  
  428. 0(DEFMETHOD (BOX :FIXED-SIZE) ()
  429.   (LET ((DISPLAY-STYLE (TELL SELF :DISPLAY-STYLE)))
  430.     (SELECTQ DISPLAY-STYLE
  431.       (:SHRUNK     (VALUES *SHRUNK-BOX-WID* *SHRUNK-BOX-HEI*))
  432.       (:NORMAL     (TELL SELF :FIXED-SIZE-1))
  433.       (OTHERWISE   (TELL SELF :FIXED-SIZE-1)))))
  434.  
  435. (DEFMETHOD (BOX :FIXED-SIZE?) ()
  436.   (OR (EQ (CAR DISPLAY-STYLE-LIST) ':FIXED)
  437.       (NUMBERP (CADR DISPLAY-STYLE-LIST))
  438.       (NUMBERP (CADDR DISPLAY-STYLE-LIST))))
  439.  
  440. (DEFMETHOD (BOX :FIXED-SIZE-1) ()
  441.   (VALUES (CADR DISPLAY-STYLE-LIST) (CADDR DISPLAY-STYLE-LIST)))
  442.  
  443. (DEFMETHOD (BOX :SET-DISPLAY-STYLE) (NEW-VALUE)
  444.   (RPLACA DISPLAY-STYLE-LIST NEW-VALUE)
  445.   (DOLIST (SCREEN-BOX (TELL SELF :SCREEN-OBJS))
  446.     (TELL SCREEN-BOX :SET-FORCE-REDISPLAY-INFS? T)))
  447.  
  448. (DEFMETHOD (BOX :SET-FIXED-SIZE) (NEW-FIXED-WID NEW-FIXED-HEI)
  449.   (RPLACA (CDR  DISPLAY-STYLE-LIST) NEW-FIXED-WID)  
  450.   (RPLACA (CDDR DISPLAY-STYLE-LIST) NEW-FIXED-HEI))
  451.  
  452. (DEFMETHOD (BOX :AFTER :SET-FIXED-SIZE) (NEW-FIXED-WID NEW-FIXED-HEI)
  453.   1;; A crock to get characters that were clipped to be redisplayed.
  454. 0  (UNLESS (AND NEW-FIXED-WID NEW-FIXED-HEI)
  455.     (DOLIST (SBOX (TELL SELF :SCREEN-OBJS))
  456.       (TELL SBOX :SET-FORCE-REDISPLAY-INFS?))))
  457.  
  458. (DEFMETHOD (SCREEN-BOX :DISPLAY-STYLE) ()
  459.   (LET ((ACTUAL-OBJ-DISPLAY-STYLE-LIST (TELL ACTUAL-OBJ :DISPLAY-STYLE-LIST)))
  460.     (OR (CAR DISPLAY-STYLE-LIST) (CAR ACTUAL-OBJ-DISPLAY-STYLE-LIST))))
  461.  
  462. (DEFMETHOD (SCREEN-BOX :FIXED-SIZE) ()
  463.   (LET ((DISPLAY-STYLE (TELL SELF :DISPLAY-STYLE)))
  464.     (SELECTQ DISPLAY-STYLE
  465.       (:SHRUNK     (VALUES *SHRUNK-BOX-WID* *SHRUNK-BOX-HEI*))
  466.       (:NORMAL     (TELL SELF :FIXED-SIZE-1))
  467.       (OTHERWISE   (TELL SELF :FIXED-SIZE-1)))))
  468.  
  469. (DEFMETHOD (SCREEN-BOX :FIXED-SIZE-1) ()
  470.   (MULTIPLE-VALUE-BIND (ACTUAL-OBJ-FIXED-WID ACTUAL-OBJ-FIXED-HEI)
  471.       (TELL ACTUAL-OBJ :FIXED-SIZE-1)
  472.     (VALUES (OR (CADR  DISPLAY-STYLE-LIST) ACTUAL-OBJ-FIXED-WID)
  473.         (OR (CADDR DISPLAY-STYLE-LIST) ACTUAL-OBJ-FIXED-HEI))))
  474.  
  475. (DEFMETHOD (SCREEN-BOX :SET-DISPLAY-STYLE) (NEW-VALUE)
  476.   (RPLACA DISPLAY-STYLE-LIST NEW-VALUE)
  477.   (TELL SELF :SET-FORCE-REDISPLAY-INFS? T))
  478.  
  479. (DEFMETHOD (SCREEN-BOX :SET-FIXED-SIZE) (NEW-FIXED-WID NEW-FIXED-HEI)
  480.   (RPLACA (CDR  DISPLAY-STYLE-LIST) NEW-FIXED-WID)  
  481.   (RPLACA (CDDR DISPLAY-STYLE-LIST) NEW-FIXED-HEI))
  482.  
  483. (DEFMETHOD (BOX :SHRINK) ()
  484.   (TELL SELF :SET-DISPLAY-STYLE ':SHRUNK)
  485.   (TELL SELF :MODIFIED))
  486.  
  487. (DEFMETHOD (BOX :UNSHRINK) ()
  488.   (TELL SELF :SET-DISPLAY-STYLE ':NORMAL)
  489.   (TELL SELF :MODIFIED))
  490.  
  491.  
  492. (DEFMETHOD (SCREEN-BOX :SHRINK) ()
  493.   (TELL ACTUAL-OBJ :SHRINK))
  494.  
  495. (DEFMETHOD (SCREEN-BOX :UNSHRINK) ()
  496.   (TELL ACTUAL-OBJ :UNSHRINK))
  497.  
  498. (DEFMETHOD (SCREEN-ROW :LENGTH) ()
  499.   (LENGTH SCREEN-CHAS))
  500.  
  501.  
  502.  
  503. ;;;stuff for BOXTOPS
  504.  
  505. (DEFMETHOD (SCREEN-BOX :NAME-AND-INPUTS-ONLY) ()
  506.   ;; add code here for displaying the inputs rather than greystuff
  507.   (TELL SELF :GRAY-BODY))
  508.  
  509. (DEFMETHOD (SCREEN-ROW :UPDATE-SIZE-FOR-NAMING-ROW) (MAX-WID IGNORE)
  510.   (WHEN (TELL SELF :NEEDS-REDISPLAY-PASS-1?)
  511.     ;; We can't use the same :REDISPLAY-PASS-1 that normal screen rows use because
  512.     ;; it erases out of synch characters which makes it REAL hard to properly erase
  513.     ;; the name by using Xoring
  514.     (SETQ SCREEN-CHAS (TELL ACTUAL-OBJ :CHAS))
  515.     ;; We can cheat here because we are guaranteed that the name row will ONLY contain
  516.     ;; characters and because a SCREEN-CHA = ACTUAL-CHA
  517.     (LOOP FOR SCREEN-CHA IN SCREEN-CHAS
  518.       FOR FONT = (FONT-NO SCREEN-CHA)
  519.       FOR CLIPPED-P = T
  520.       SUM (CHA-WID FONT (CHA-CODE SCREEN-CHA)) INTO WIDTH
  521.       MAXIMIZE (CHA-HEI FONT) INTO HEIGHT
  522.       WHILE (< WIDTH MAX-WID)
  523.       DO (SETQ CLIPPED-P NIL)
  524.       FINALLY
  525.       (SETQ NEW-WID WIDTH
  526.         NEW-HEI HEIGHT
  527.         NEW-X-GOT-CLIPPED? CLIPPED-P))
  528.     (TELL SELF :GOT-REDISPLAYED)))
  529.  
  530.  
  531.  
  532. ;;; Things having to do with a window's outermost screen box.
  533.  
  534. (DEFUN OUTERMOST-BOX (&OPTIONAL (WINDOW *BOXER-PANE*))
  535.   (SCREEN-OBJ-ACTUAL-OBJ (OUTERMOST-SCREEN-BOX WINDOW)))
  536.  
  537. (DEFUN OUTERMOST-SCREEN-BOX (&OPTIONAL (WINDOW *BOXER-PANE*))
  538.   (TELL WINDOW :OUTERMOST-SCREEN-BOX))
  539.  
  540. (DEFMETHOD (ACTUAL-OBJ-MIXIN :DISPLAYED-SCREEN-OBJS) (&OPTIONAL (WINDOW *BOXER-PANE*))
  541.   (LET ((ALL-SCREEN-OBJS (TELL SELF :SCREEN-OBJS))
  542.     (OUTERMOST-SCREEN-BOX (OUTERMOST-SCREEN-BOX WINDOW)))
  543.     (WITH-COLLECTION
  544.       (DOLIST (SCREEN-OBJ ALL-SCREEN-OBJS)
  545.     (IF (TELL SCREEN-OBJ :SUPERIOR? OUTERMOST-SCREEN-BOX)
  546.         (COLLECT SCREEN-OBJ))))))
  547.  
  548. (DEFMETHOD (SCREEN-OBJ :SUPERIOR?) (SCREEN-OBJ)
  549.   "Is the Arg a superior of the instance ?"
  550.   (LET ((SUPERIOR (TELL SELF :SUPERIOR)))
  551.     (OR (EQ SCREEN-OBJ SELF)
  552.     (EQ SCREEN-OBJ SUPERIOR)
  553.     (AND (SCREEN-OBJ? SUPERIOR)
  554.          (TELL SUPERIOR :SUPERIOR? SCREEN-OBJ)))))
  555.  
  556. ;;; Stuff for zooming in and out of boxes
  557.  
  558. (DEFUN GET-PREVIOUS-OUTERMOST-BOX-VALUES ()
  559.   (LET ((PREVIOUS-OUTERMOST-SCREEN-BOX (POP *OUTERMOST-SCREEN-BOX-STACK*)))
  560.     (IF (NULL PREVIOUS-OUTERMOST-SCREEN-BOX)
  561.     (VALUES *INITIAL-BOX* (CAR (TELL *INITIAL-BOX* :SCREEN-OBJS)))
  562.     (VALUES (TELL PREVIOUS-OUTERMOST-SCREEN-BOX :ACTUAL-OBJ)
  563.         PREVIOUS-OUTERMOST-SCREEN-BOX))))
  564.  
  565. (DEFSUBST BOX-BORDER-ZOOM-IN (NEW-SCREEN-BOX WINDOW)
  566.   (DRAWING-ON-WINDOW (WINDOW)
  567.     (WHEN (TELL NEW-SCREEN-BOX :VISIBLE?) 
  568.       (MULTIPLE-VALUE-BIND (NEW-SCREEN-BOX-WID NEW-SCREEN-BOX-HEI)
  569.       (SCREEN-OBJ-SIZE NEW-SCREEN-BOX)
  570.     (MULTIPLE-VALUE-BIND (NEW-SCREEN-BOX-X NEW-SCREEN-BOX-Y)
  571.         (TELL NEW-SCREEN-BOX :POSITION)
  572.       (MULTIPLE-VALUE-BIND (OUTERMOST-SCREEN-BOX-WID OUTERMOST-SCREEN-BOX-HEI)
  573.           (OUTERMOST-SCREEN-BOX-SIZE)
  574.         (MULTIPLE-VALUE-BIND (OUTERMOST-SCREEN-BOX-X OUTERMOST-SCREEN-BOX-Y)
  575.         (OUTERMOST-SCREEN-BOX-POSITION)    
  576.           (BOX-BORDERS-FN ':ZOOM (TELL (TELL NEW-SCREEN-BOX :ACTUAL-OBJ) :TYPE)
  577.                   NEW-SCREEN-BOX
  578.                   OUTERMOST-SCREEN-BOX-WID OUTERMOST-SCREEN-BOX-HEI
  579.                   NEW-SCREEN-BOX-WID NEW-SCREEN-BOX-HEI
  580.                   OUTERMOST-SCREEN-BOX-X OUTERMOST-SCREEN-BOX-Y
  581.                   NEW-SCREEN-BOX-X NEW-SCREEN-BOX-Y
  582.                   20.))))))))
  583.  
  584. (DEFSUBST BOX-BORDER-ZOOM-OUT (OLD-SCREEN-BOX WINDOW)
  585.   (DRAWING-ON-WINDOW (WINDOW)
  586.     (WHEN (TELL OLD-SCREEN-BOX :VISIBLE?) 
  587.       (MULTIPLE-VALUE-BIND (OLD-SCREEN-BOX-WID OLD-SCREEN-BOX-HEI)
  588.       (SCREEN-OBJ-SIZE OLD-SCREEN-BOX)
  589.     (MULTIPLE-VALUE-BIND (OLD-SCREEN-BOX-X OLD-SCREEN-BOX-Y)
  590.         (TELL OLD-SCREEN-BOX :POSITION)
  591.       (MULTIPLE-VALUE-BIND (OUTERMOST-SCREEN-BOX-WID OUTERMOST-SCREEN-BOX-HEI)
  592.           (OUTERMOST-SCREEN-BOX-SIZE)
  593.         (MULTIPLE-VALUE-BIND (OUTERMOST-SCREEN-BOX-X OUTERMOST-SCREEN-BOX-Y)
  594.         (OUTERMOST-SCREEN-BOX-POSITION)    
  595.           (BOX-BORDERS-FN ':ZOOM (TELL (TELL OLD-SCREEN-BOX :ACTUAL-OBJ) :TYPE)
  596.                   OLD-SCREEN-BOX
  597.                   OLD-SCREEN-BOX-WID OLD-SCREEN-BOX-HEI
  598.                   OUTERMOST-SCREEN-BOX-WID OUTERMOST-SCREEN-BOX-HEI
  599.                   OLD-SCREEN-BOX-X OLD-SCREEN-BOX-Y
  600.                   OUTERMOST-SCREEN-BOX-X OUTERMOST-SCREEN-BOX-Y
  601.                   16.))))))))
  602.  
  603. (DEFUN SET-OUTERMOST-BOX (NEW-OUTERMOST-BOX &OPTIONAL (NEW-OUTERMOST-SCREEN-BOX
  604.                             (CAR (TELL-CHECK-NIL
  605.                                    NEW-OUTERMOST-BOX
  606.                                    :DISPLAYED-SCREEN-OBJS)))
  607.               (WINDOW *BOXER-PANE*))
  608.   (LET ((OLD-OUTERMOST-SCREEN-BOX *OUTERMOST-SCREEN-BOX*))
  609.     (IF (OR (GRAPHICS-BOX? NEW-OUTERMOST-BOX)
  610.         (AND (PORT-BOX? NEW-OUTERMOST-BOX)
  611.          (GRAPHICS-BOX? (TELL NEW-OUTERMOST-BOX :PORTS))))
  612.     (BEEP)
  613.     (WHEN (NAME-ROW? (POINT-ROW)) (MOVE-POINT (BOX-FIRST-BP-VALUES NEW-OUTERMOST-BOX)))
  614.     (REDRAW-STATUS-LINE (TELL NEW-OUTERMOST-BOX :NAME))
  615.     (BOX-BORDER-ZOOM-OUT NEW-OUTERMOST-SCREEN-BOX WINDOW)
  616.     (SET-OUTERMOST-SCREEN-BOX
  617.       (tell new-outermost-box :allocate-outermost-screen-box-for-use-in window
  618.         NEW-OUTERMOST-SCREEN-BOX)
  619.       WINDOW)
  620.     (BOX-BORDER-ZOOM-IN OLD-OUTERMOST-SCREEN-BOX WINDOW))))
  621.  
  622. ;;;these should go somewhere else eventually...
  623. (DEFMETHOD (SCREEN-OBJ :VISIBLE?)()
  624.   (MEMQ SELF (TELL (TELL SELF :ACTUAL-OBJ) :DISPLAYED-SCREEN-OBJS)))
  625.  
  626. (DEFUN SET-OUTERMOST-SCREEN-BOX (NEW-OUTERMOST-SCREEN-BOX &OPTIONAL (WINDOW *BOXER-PANE*))
  627.   (WITHOUT-INTERRUPTS                ;keep the mouse process from looking at 
  628.     (REDISPLAYING-WINDOW (WINDOW)        ;the screen when it is in a munged state
  629.       (UNLESS (EQ NEW-OUTERMOST-SCREEN-BOX *OUTERMOST-SCREEN-BOX*)
  630.     (DECONFIGURE-SCREEN-BOX-TO-BE-OUTERMOST-BOX *OUTERMOST-SCREEN-BOX* WINDOW)
  631.     (CONFIGURE-SCREEN-BOX-TO-BE-OUTERMOST-BOX NEW-OUTERMOST-SCREEN-BOX WINDOW)
  632.     (ERASE-SCREEN-OBJ *OUTERMOST-SCREEN-BOX*) 
  633.     (SETQ *OUTERMOST-SCREEN-BOX* NEW-OUTERMOST-SCREEN-BOX)))
  634.     (SETQ *OUTERMOST-SCREEN-BOX* (OUTERMOST-SCREEN-BOX))    ;why is this neccessary ?
  635.     (LET ((*COMPLETE-REDISPLAY-IN-PROGRESS?* T)
  636.       (OLD-SCREEN-ROW (TELL-CHECK-NIL NEW-OUTERMOST-SCREEN-BOX :SCREEN-ROW)))
  637.       (WHEN (SCREEN-ROW? OLD-SCREEN-ROW)
  638.     ;; we need to break up the screen-structure
  639.     (TELL OLD-SCREEN-ROW :KILL-SCREEN-CHAS-FROM 0)
  640.     (TELL (TELL OLD-SCREEN-ROW :SUPERIOR) :DEALLOCATE-SELF))
  641.       (REDISPLAY-WINDOW WINDOW))))
  642.  
  643. (DEFUN CONFIGURE-SCREEN-BOX-TO-BE-OUTERMOST-BOX (SCREEN-BOX &OPTIONAL (WINDOW *BOXER-PANE*))
  644.   (MULTIPLE-VALUE-BIND (MAX-WID MAX-HEI)
  645.       (OUTERMOST-SCREEN-BOX-SIZE WINDOW)
  646.     (MULTIPLE-VALUE-BIND (X-OFFSET Y-OFFSET)
  647.     (OUTERMOST-SCREEN-BOX-POSITION WINDOW)
  648.       (TELL SCREEN-BOX :SET-DISPLAY-STYLE ':NORMAL)
  649.       (TELL SCREEN-BOX :SET-FIXED-SIZE MAX-WID MAX-HEI)      
  650.       (TELL SCREEN-BOX :SET-OFFSETS X-OFFSET Y-OFFSET))))
  651.  
  652. (DEFUN DECONFIGURE-SCREEN-BOX-TO-BE-OUTERMOST-BOX (SCREEN-BOX &OPTIONAL IGNORE)
  653.   (TELL SCREEN-BOX :SET-DISPLAY-STYLE NIL)
  654.   (TELL SCREEN-BOX :SET-FIXED-SIZE NIL NIL)
  655.   (TELL SCREEN-BOX :SET-OFFSETS 0 0))
  656.  
  657.  
  658. ;;;; Interaction with redisplayable-window-mixin.
  659.  
  660. (DEFMETHOD (REDISPLAYABLE-WINDOW-MIXIN :BEFORE :INIT) (&REST IGNORE)
  661.   (UNLESS (MEMQ SELF *REDISPLAYABLE-WINDOWS*)
  662.       (PUSH SELF *REDISPLAYABLE-WINDOWS*)))
  663.  
  664. (DEFMETHOD (REDISPLAYABLE-WINDOW-MIXIN :AFTER :KILL) (&REST IGNORE)
  665.   (SETQ *REDISPLAYABLE-WINDOWS* (DELETE SELF *REDISPLAYABLE-WINDOWS*)))
  666.  
  667. (DEFMETHOD (REDISPLAYABLE-WINDOW-MIXIN :OUTERMOST-SCREEN-BOX) ()
  668.   OUTERMOST-SCREEN-BOX)
  669.  
  670. (DEFMETHOD (REDISPLAYABLE-WINDOW-MIXIN :SET-OUTERMOST-SCREEN-BOX) (NEW-VALUE)
  671.   (SETQ OUTERMOST-SCREEN-BOX NEW-VALUE))
  672.  
  673.  
  674.  
  675. (DEFUN REDISPLAY-CLUE (TYPE &REST ARGS)
  676.   (LET ((HANDLER (GET TYPE ':REDISPLAY-CLUE)))
  677.     (IF (NOT-NULL HANDLER)
  678.     (LEXPR-FUNCALL HANDLER TYPE ARGS)
  679.     (FERROR "~S is an unknown type of redisplay-clue." TYPE))))
  680.  
  681. (DEFUN (:PROPERTY :CLEAR-SCREEN :REDISPLAY-CLUE) (&REST IGNORE)
  682.   (PUSH '(:CLEAR-SCREEN) *REDISPLAY-CLUES*))
  683.  
  684.  
  685.  
  686.  
  687.  
  688. (DEFUN OUTERMOST-SCREEN-BOX? (SCREEN-OBJ)
  689.   (AND (SCREEN-BOX? SCREEN-OBJ)
  690.        (EQ SCREEN-OBJ (OUTERMOST-SCREEN-BOX))))
  691.  
  692. (DEFMETHOD (SCREEN-OBJ :POSITION) (&AUX TEMP)
  693.   (MULTIPLE-VALUE-BIND (SUPERIOR-X-OFF SUPERIOR-Y-OFF)
  694.       (COND ((OUTERMOST-SCREEN-BOX? SELF)
  695.          (VALUES 0 0))
  696.         (T
  697.          (SETQ TEMP (TELL SELF :SUPERIOR))
  698.          (TELL TEMP :POSITION)))
  699.     (VALUES (+ SUPERIOR-X-OFF X-OFFSET)
  700.         (+ SUPERIOR-Y-OFF Y-OFFSET))))
  701.  
  702. (DEFMETHOD (SCREEN-CHA :NEXT-SCREEN-CHA-POSITION) ()
  703.   (MULTIPLE-VALUE-BIND (X Y)
  704.       (TELL SELF :POSITION)
  705.     (VALUES (+ X WID) Y)))
  706.  
  707. (DEFMETHOD (SCREEN-ROW :FIRST-SCREEN-CHA-POSITION) ()
  708.   (TELL SELF :POSITION))
  709.  
  710. (DEFMETHOD (SCREEN-BOX :FIRST-SCREEN-CHA-POSITION) ()
  711.   (MULTIPLE-VALUE-BIND (X Y)
  712.       (TELL SELF :POSITION)
  713.     (MULTIPLE-VALUE-BIND (IL IT NIL NIL)
  714.     (SCREEN-BOX-BORDERS-FN ':BORDER-WIDS SELF)
  715.       (VALUES (+ X IL) (+ Y IT)))))
  716.  
  717.  
  718. ;;;box border functions...
  719. ;leave these out for now until name tags are finished
  720. ;(DEFFLAVOR BOX-BORDERS-BLINKER
  721. ;    ((BOX-TYPE ':DOIT)
  722. ;     (WINDOW-X 0)
  723. ;     (WINDOW-Y 0)
  724. ;     (WID 0)
  725. ;     (HEI 0))
  726. ;    ;; There is no sense giving the the mouse
  727. ;    ;; fast tracking blinker mixin. Since it
  728. ;    ;; changes size all the time, and it will
  729. ;    ;; often be bigger than 32. by 32.
  730. ;    (TV:MOUSE-BLINKER-MIXIN TV:BLINKER))
  731. ;
  732. ;(DEFMETHOD (BOX-BORDERS-BLINKER :BEFORE :INIT) (&REST IGNORE)
  733. ;  (MULTIPLE-VALUE-BIND (X-OFF Y-OFF)
  734. ;      (TV:SHEET-CALCULATE-OFFSETS *BOXER-PANE* TV:MAIN-SCREEN)
  735. ;    (TELL SELF :SET-OFFSETS X-OFF Y-OFF)))
  736. ;
  737. ;(DEFMETHOD (BOX-BORDERS-BLINKER :SET-BOX-TYPE) (NEW-VALUE)
  738. ;  (OR (EQ NEW-VALUE BOX-TYPE)
  739. ;      (TV:PREPARE-SHEET (TV:SHEET)
  740. ;    (TV:OPEN-BLINKER SELF)
  741. ;    (SETQ BOX-TYPE NEW-VALUE))))
  742. ;
  743. ;(DEFMETHOD (BOX-BORDERS-BLINKER :SET-WINDOW-X) (NEW-VALUE)
  744. ;  (OR (EQ NEW-VALUE WINDOW-X)
  745. ;      (TV:PREPARE-SHEET (TV:SHEET)
  746. ;    (TV:OPEN-BLINKER SELF)
  747. ;    (SETQ WINDOW-X NEW-VALUE))))
  748. ;
  749. ;(DEFMETHOD (BOX-BORDERS-BLINKER :SET-WINDOW-Y) (NEW-VALUE)
  750. ;  (OR (EQ NEW-VALUE WINDOW-Y)
  751. ;      (TV:PREPARE-SHEET (TV:SHEET)
  752. ;    (TV:OPEN-BLINKER SELF)
  753. ;    (SETQ WINDOW-Y NEW-VALUE))))
  754. ;
  755. ;(DEFMETHOD (BOX-BORDERS-BLINKER :SET-CURSORPOS) (X Y)
  756. ;  (MULTIPLE-VALUE-BIND (MIN-WID MIN-HEI)
  757. ;      (BOX-BORDERS-FN ':MINIMUM-SIZE BOX-TYPE)
  758. ;    (LET ((NEW-WID (MAX MIN-WID (- X WINDOW-X)))
  759. ;      (NEW-HEI (MAX MIN-HEI (- Y WINDOW-Y))))
  760. ;      (OR (AND (EQ WID NEW-WID) (EQ HEI NEW-HEI))
  761. ;      (TV:PREPARE-SHEET (TV:SHEET)
  762. ;        (TV:OPEN-BLINKER SELF)
  763. ;        (SETQ WID NEW-WID
  764. ;          HEI NEW-HEI))))))
  765. ;
  766. ;(DEFMETHOD (BOX-BORDERS-BLINKER :READ-CURSORPOS) ()
  767. ;  (VALUES WINDOW-X WINDOW-Y))
  768. ;
  769. ;(DEFMETHOD (BOX-BORDERS-BLINKER :SET-WID) (NEW-VALUE)
  770. ;  (OR (EQ NEW-VALUE WID)
  771. ;      (TV:PREPARE-SHEET (TV:SHEET)
  772. ;    (TV:OPEN-BLINKER SELF)
  773. ;    (SETQ WID NEW-VALUE))))
  774. ;
  775. ;(DEFMETHOD (BOX-BORDERS-BLINKER :SET-HEI) (NEW-VALUE)
  776. ;  (OR (EQ HEI NEW-VALUE)
  777. ;      (TV:PREPARE-SHEET (TV:SHEET)
  778. ;    (TV:OPEN-BLINKER SELF)
  779. ;    (SETQ HEI NEW-VALUE))))
  780. ;
  781. ;(DEFMETHOD (BOX-BORDERS-BLINKER :SIZE) ()
  782. ;  (VALUES WID HEI))
  783. ;
  784. ;(DEFMETHOD (BOX-BORDERS-BLINKER :BLINK) ()
  785. ;  (DRAWING-ON-WINDOW-WITHOUT-PREPARE-SHEET (TV:SHEET)
  786. ;    (BOX-BORDERS-FN ':DRAW BOX-TYPE WID HEI WINDOW-X WINDOW-Y)))
  787. ;
  788. ;(DEFUN ADJUST-BOX-SIZE-WITH-MOUSE (WINDOW)
  789. ;  (USING-BOX-BORDERS-BLINKER (BL)
  790. ;    (MULTIPLE-VALUE-BIND (WINDOW-X WINDOW-Y)
  791. ;    (MOUSE-POSITION-IN-WINDOW-COORDINATES WINDOW)
  792. ;      (LET* ((SCREEN-BOX (FIND-SCREEN-BOX-AT-POSITION WINDOW-X WINDOW-Y WINDOW))
  793. ;         (ACTUAL-BOX (SCREEN-OBJ-ACTUAL-OBJ SCREEN-BOX))
  794. ;         (BOX-TYPE (TELL ACTUAL-BOX :TYPE))
  795. ;         (WID (SCREEN-OBJ-WID SCREEN-BOX))
  796. ;         (HEI (SCREEN-OBJ-HEI SCREEN-BOX)))
  797. ;    (MULTIPLE-VALUE-BIND (WINDOW-X WINDOW-Y)
  798. ;        (SCREEN-OBJ-POSITION SCREEN-BOX)
  799. ;      (TELL BL :SET-WINDOW-X WINDOW-X)
  800. ;      (TELL BL :SET-WINDOW-Y WINDOW-Y)
  801. ;      (MULTIPLE-VALUE-BIND (X-OFFSET Y-OFFSET)
  802. ;          (TV:SHEET-CALCULATE-OFFSETS WINDOW TV:MOUSE-SHEET)
  803. ;        (MULTIPLE-VALUE-BIND (IL IT NIL NIL)
  804. ;        (TELL WINDOW :MARGINS)
  805. ;          (TV:MOUSE-WARP (+ X-OFFSET IL WINDOW-X WID)
  806. ;                 (+ Y-OFFSET IT WINDOW-Y HEI))))
  807. ;      (DRAWING-ON-WINDOW (*BOXER-PANE*)
  808. ;        (BOX-BORDERS-FN ':DRAW BOX-TYPE WID HEI WINDOW-X WINDOW-Y))
  809. ;      (TELL BL :SET-VISIBILITY ':ON)
  810. ;      (TELL BL :TRACK-MOUSE)
  811. ;      (PROCESS-WAIT "Adjust Size" #'ADJUST-BOX-SIZE-WITH-MOUSE-SLEEP-FN)
  812. ;      (MULTIPLE-VALUE-BIND (NEW-WID NEW-HEI)
  813. ;          (TELL BL :SIZE)
  814. ;        (TELL ACTUAL-BOX :SET-FIXED-SIZE NEW-WID NEW-HEI))
  815. ;      (USE-CURSOR-BLINKER)
  816. ;      (DRAWING-ON-WINDOW (*BOXER-PANE*)
  817. ;        (BOX-BORDERS-FN ':DRAW BOX-TYPE WID HEI WINDOW-X WINDOW-Y))
  818. ;      (FORCE-REDISPLAY)
  819. ;      (SETQ MOUSE-MOVES-HANDLER 'MOUSE-IS-STOPPED-HANDLER
  820. ;        TV:MOUSE-RECONSIDER T))))))
  821. ;
  822. ;(DEFUN ADJUST-BOX-SIZE-WITH-MOUSE-SLEEP-FN ()
  823. ;  (ZEROP TV:MOUSE-LAST-BUTTONS))
  824.  
  825.  
  826.  
  827. (DEFUN OUTERMOST-SCREEN-BOX-SIZE (&OPTIONAL (WINDOW *BOXER-PANE*))
  828.   (MULTIPLE-VALUE-BIND (WINDOW-INNER-WID WINDOW-INNER-HEI)
  829.       (TELL WINDOW :INSIDE-SIZE)
  830.     (VALUES (- WINDOW-INNER-WID (* 2 *SPACE-AROUND-OUTERMOST-SCREEN-BOX*))
  831.         (- WINDOW-INNER-HEI (* 2 *SPACE-AROUND-OUTERMOST-SCREEN-BOX*)))))
  832.  
  833. (DEFUN OUTERMOST-SCREEN-BOX-POSITION (&OPTIONAL IGNORE)
  834.   (VALUES *SPACE-AROUND-OUTERMOST-SCREEN-BOX*
  835.       *SPACE-AROUND-OUTERMOST-SCREEN-BOX*))
  836.  
  837.  
  838. ;;;;Operations Particular to SCREEN-BPs.
  839.  
  840. (DEFUN CURRENT-SCREEN-ROW (ACTUAL-ROW &OPTIONAL (SCREEN-BOX (BP-SCREEN-BOX *POINT*)))
  841.   (LET ((SCREEN-ROWS (TELL ACTUAL-ROW :DISPLAYED-SCREEN-OBJS)))
  842.     (DOLIST (SCREEN-ROW SCREEN-ROWS)
  843.       (WHEN (EQ (TELL SCREEN-ROW :SUPERIOR) SCREEN-BOX)
  844.     (RETURN SCREEN-ROW)))))
  845.  
  846. (DEFUN BP-POSITIONS (BP)
  847.   (CHECK-BP-ARG BP)
  848.   (LET ((BOX (BP-BOX BP))
  849.     (ROW (BP-ROW BP)))
  850.     (COND ((NULL BOX) NIL)
  851.       ((NAME-ROW? ROW)
  852.        (SCREEN-BOX-NAME-ROW-BP-POSITION (BP-SCREEN-BOX *POINT*) ROW))
  853.       ((EQ ':SHRUNK (TELL (BP-SCREEN-BOX *POINT*) :DISPLAY-STYLE))
  854.        (SCREEN-BOX-FIRST-BP-POSITION (BP-SCREEN-BOX *POINT*)))
  855.       ((NULL (CURRENT-SCREEN-ROW ROW))
  856.        (SCREEN-BOX-LAST-BP-POSITION (BP-SCREEN-BOX *POINT*)))
  857.       (T
  858.        (ROW-POINT-POSITION (CURRENT-SCREEN-ROW ROW))))))
  859.  
  860. (DEFUN SCREEN-BOX-FIRST-BP-POSITION (SCREEN-BOX)
  861.   (MULTIPLE-VALUE-BIND (X Y)
  862.       (TELL SCREEN-BOX :POSITION)
  863.     (MULTIPLE-VALUE-BIND (IL IT IGNORE IGNORE)
  864.     (SCREEN-BOX-BORDERS-FN ':BORDER-WIDS SCREEN-BOX)
  865.       (CONS (+ X IL) (+ Y IT)))))
  866.  
  867. (DEFUN SCREEN-BOX-LAST-BP-POSITION (SCREEN-BOX)
  868.   (MULTIPLE-VALUE-BIND (X Y)
  869.       (TELL SCREEN-BOX :POSITION)
  870.     (CONS (+ X (TELL SCREEN-BOX :WID))
  871.       (- (+ Y (TELL SCREEN-BOX :HEI)) *MINIMUM-CURSOR-HEIGHT*))))
  872.  
  873. (DEFUN SCREEN-BOX-NAME-ROW-BP-POSITION  (SCREEN-BOX NAME-ROW)
  874.   (LET ((CHA-NO (BP-CHA-NO *POINT*)))
  875.     (MULTIPLE-VALUE-BIND (X Y)
  876.     (TELL SCREEN-BOX :POSITION)
  877.       (MULTIPLE-VALUE-BIND (TAB-X TAB-Y)
  878.       (SCREEN-BOX-BORDERS-FN ':TAB-OFFSETS SCREEN-BOX)
  879.     (LOOP FOR CHA IN (TELL NAME-ROW :CHAS)
  880.           FOR INDEX = 0 THEN (1+ INDEX)
  881.           UNTIL (= INDEX CHA-NO)
  882.           SUM (CHA-WID (FONT-NO CHA) (CHA-CODE CHA)) INTO LAST-X
  883.           FINALLY (RETURN (CONS (+ X TAB-X LAST-X) (+ Y TAB-Y))))))))
  884.  
  885. (DEFUN ROW-POINT-POSITION (SCREEN-ROW)
  886.   (LET* ((ROW (TELL SCREEN-ROW :ACTUAL-OBJ))
  887.      (LENGTH-IN-CHAS (TELL ROW :LENGTH-IN-CHAS))
  888.      (CHA-NO (BP-CHA-NO *POINT*)))
  889.     (COND ((NULL (BP-SCREEN-BOX *POINT*))
  890.        (FERROR NIL "Lost the current Screen Box"))
  891.       ((>= CHA-NO LENGTH-IN-CHAS)
  892.        (END-OF-ROW-POINT-LOCATION SCREEN-ROW)) 
  893.       (T (INSIDE-OF-ROW-POINT-LOCATION SCREEN-ROW CHA-NO)))))
  894.  
  895. (DEFUN END-OF-ROW-POINT-LOCATION (SCREEN-ROW)
  896.   (MULTIPLE-VALUE-BIND (SCREEN-ROW-X SCREEN-ROW-Y)
  897.       (TELL SCREEN-ROW :POSITION)
  898.     (CONS (+ SCREEN-ROW-X (SCREEN-OBJ-WID SCREEN-ROW)) SCREEN-ROW-Y)))
  899.  
  900. (DEFUN INSIDE-OF-ROW-POINT-LOCATION (SCREEN-ROW CHA-NO)
  901.   (MULTIPLE-VALUE-BIND (SCREEN-ROW-X SCREEN-ROW-Y)
  902.       (TELL SCREEN-ROW :POSITION)
  903.     (CONS (+ SCREEN-ROW-X (X-COORDINATE-OF-CHA-NO SCREEN-ROW CHA-NO)) SCREEN-ROW-Y)))
  904.  
  905. (DEFUN X-COORDINATE-OF-CHA-NO (ROW CHA-NO &AUX(X-COORD 0))
  906.   (DO* ((INDEX 0 (+ INDEX 1))
  907.     (CHA (TELL ROW :SCREEN-CHA-AT-CHA-NO INDEX) (TELL ROW :SCREEN-CHA-AT-CHA-NO INDEX)))
  908.        ((OR (NULL CHA)(= INDEX CHA-NO)) X-COORD)
  909.     (SETQ X-COORD (+ X-COORD (SCREEN-OBJECT-WIDTH CHA)))))
  910.  
  911.  
  912.  
  913. (DEFUN FIND-SCREEN-BP-AT-POSITION (X Y &OPTIONAL (WINDOW *BOXER-PANE*))
  914.   (REDISPLAYING-WINDOW (WINDOW)
  915.     (MULTIPLE-VALUE-BIND (OUTERMOST-SCREEN-BOX-X-OFFSET OUTERMOST-SCREEN-BOX-Y-OFFSET)
  916.     (OUTERMOST-SCREEN-BOX-POSITION WINDOW)
  917.       (TELL (OUTERMOST-SCREEN-BOX WINDOW) :FIND-SCREEN-BP-AT-OFFSET
  918.                       (- X OUTERMOST-SCREEN-BOX-X-OFFSET)
  919.                       (- Y OUTERMOST-SCREEN-BOX-Y-OFFSET)))))
  920.  
  921. (DEFMETHOD (SCREEN-CHA :FIND-SCREEN-BP-AT-OFFSET) (X-OFF Y-OFF)
  922.   Y-OFF                        ;prevent bound but never used warnings
  923.   (IF (> X-OFF (// WID 2))
  924.       (TELL SELF :NEXT-SCREEN-BP)
  925.       (TELL SELF :SCREEN-BP)))
  926.  
  927. (DEFMETHOD (SCREEN-ROW :FIND-SCREEN-BP-AT-OFFSET) (X-OFF Y-OFF &AUX TEMP)
  928.   (DO* ((ITER-SCREEN-CHAS SCREEN-CHAS (CDR ITER-SCREEN-CHAS))
  929.     (SCREEN-CHA (CAR ITER-SCREEN-CHAS) (CAR ITER-SCREEN-CHAS)))
  930.        ((NULL ITER-SCREEN-CHAS)
  931.     ;; We have gone through all this screen row's screen chas
  932.     ;; without finding a screen cha at the specified offset.
  933.     ;; Just return this screen-row's last screen bp.
  934.     (TELL SELF :LAST-SCREEN-BP))
  935.     (LET ((SCREEN-CHA-X-OFFSET (SCREEN-OBJ-X-OFFSET SCREEN-CHA))
  936.       (SCREEN-CHA-Y-OFFSET (SCREEN-OBJ-Y-OFFSET SCREEN-CHA))
  937.       (SCREEN-CHA-WID (SCREEN-OBJ-WID SCREEN-CHA))
  938.       (SCREEN-CHA-HEI (SCREEN-OBJ-HEI SCREEN-CHA)))
  939.       (COND ((AND (> (+ SCREEN-CHA-X-OFFSET SCREEN-CHA-WID) X-OFF)
  940.           (< SCREEN-CHA-HEI Y-OFF)
  941.           (> Y-OFF (// (+ HEI SCREEN-CHA-HEI) 2))
  942.           (NOT-NULL (SETQ TEMP (TELL SELF :NEXT-SCREEN-ROW))))
  943.          ;; This screen cha is at the right x-off, but it is so
  944.          ;; short that the specified offset is actually closer
  945.          ;; to somehing in the next screen row. So ask the next
  946.          ;; screen row to find that something. [Note the next
  947.          ;; screen row won't screw us by passing the buck back
  948.          ;; cause the rule says you can only pass the buck down].
  949.          (RETURN
  950.            (TELL TEMP :FIND-SCREEN-BP-AT-OFFSET
  951.               (- X-OFF (- (SCREEN-OBJ-X-OFFSET TEMP) X-OFFSET))
  952.               (- Y-OFF (- (SCREEN-OBJ-Y-OFFSET TEMP) Y-OFFSET)))))
  953.         ((> (+ SCREEN-CHA-X-OFFSET SCREEN-CHA-WID) X-OFF)
  954.          ;; This screen cha is at the right x-off, and it is
  955.          ;; tall enough to catch the y-off too.
  956.          (RETURN
  957.            (TELL SCREEN-CHA :FIND-SCREEN-BP-AT-OFFSET
  958.                 (- X-OFF SCREEN-CHA-X-OFFSET)
  959.                 (- Y-OFF SCREEN-CHA-Y-OFFSET))))))))
  960.  
  961. (DEFMETHOD (SCREEN-BOX :FIND-SCREEN-BP-AT-OFFSET) (X-OFF Y-OFF)
  962.   (DO* ((ITER-SCREEN-ROWS SCREEN-ROWS (CDR ITER-SCREEN-ROWS))
  963.     (ITER-SCREEN-ROW (CAR ITER-SCREEN-ROWS) (CAR ITER-SCREEN-ROWS)))
  964.        ((NULL ITER-SCREEN-ROWS)
  965.     ;; We have gone through all this screen box's screen rows
  966.     ;; without finding a screen row at the specified offset.
  967.     ;; Just return this screen-box's last screen-bp
  968.     (TELL SELF :LAST-SCREEN-BP))
  969.     (LET ((ITER-SCREEN-ROW-X-OFFSET (SCREEN-OBJ-X-OFFSET ITER-SCREEN-ROW))
  970.       (ITER-SCREEN-ROW-Y-OFFSET (SCREEN-OBJ-Y-OFFSET ITER-SCREEN-ROW))
  971.       (ITER-SCREEN-ROW-HEI (SCREEN-OBJ-HEI ITER-SCREEN-ROW)))
  972.       (COND ((AND (> (+ ITER-SCREEN-ROW-Y-OFFSET ITER-SCREEN-ROW-HEI) Y-OFF)
  973.           (SCREEN-ROW? ITER-SCREEN-ROW))
  974.          (RETURN
  975.            (TELL ITER-SCREEN-ROW :FIND-SCREEN-BP-AT-OFFSET
  976.                      (- X-OFF ITER-SCREEN-ROW-X-OFFSET)
  977.                      (- Y-OFF ITER-SCREEN-ROW-Y-OFFSET))))))))
  978.  
  979. (DEFMETHOD (SCREEN-CHA :SCREEN-BP) ()
  980.   (LET ((BP (MAKE-BP 'FIXED)))
  981.     (MOVE-BP BP (CHA-BP-VALUES ACTUAL-OBJ))
  982.     BP))
  983.  
  984. (DEFMETHOD (SCREEN-CHA :NEXT-SCREEN-BP) ()
  985.   (LET ((BP (MAKE-BP 'FIXED)))
  986.     (MOVE-BP BP (CHA-NEXT-BP-VALUES ACTUAL-OBJ))
  987.     BP))
  988.  
  989. (DEFMETHOD (SCREEN-ROW :FIRST-SCREEN-BP) ()
  990.   (LET ((BP (MAKE-BP 'FIXED)))
  991.     (MOVE-BP BP (ROW-FIRST-BP-VALUES ACTUAL-OBJ))
  992.     BP))
  993.  
  994. (DEFMETHOD (SCREEN-ROW :LAST-SCREEN-BP) ()
  995.   (LET ((BP (MAKE-BP 'FIXED)))
  996.     (MOVE-BP BP (ROW-LAST-BP-VALUES ACTUAL-OBJ))
  997.     BP))
  998.  
  999. (DEFMETHOD (SCREEN-BOX :FIRST-SCREEN-BP) ()
  1000.   (LET ((BP (MAKE-BP 'FIXED)))
  1001.     (MOVE-BP BP (BOX-FIRST-BP-VALUES ACTUAL-OBJ))
  1002.     BP))
  1003.  
  1004. (DEFMETHOD (SCREEN-BOX :LAST-SCREEN-BP) ()
  1005.   (LET ((BP (MAKE-BP 'FIXED)))
  1006.     (MOVE-BP BP (BOX-LAST-BP-VALUES ACTUAL-OBJ))
  1007.     BP))
  1008.  
  1009. (DEFUN SCREEN-BOX ()
  1010.   (TELL *POINT* :SCREEN-BOX))
  1011.  
  1012. (DEFUN SCREEN-ROW ()
  1013.   (TELL (TELL *POINT* :ROW) :ALLOCATE-SCREEN-OBJ-FOR-USE-IN (SCREEN-BOX)))
  1014.  
  1015. (DEFUN INF-CURRENT-SCREEN-BOX (BOX)        ;returns the screen obj of box which is within
  1016.   (CAR (MEM #'(LAMBDA (SUPERIOR-BOX BOX) (EQ SUPERIOR-BOX (TELL BOX :SUPERIOR-SCREEN-BOX)))
  1017.         (BP-SCREEN-BOX *POINT*)
  1018.         (TELL BOX :DISPLAYED-SCREEN-OBJS))))
  1019.  
  1020.  
  1021.  
  1022. ;;;; BOX-BORDERS-FN
  1023.  
  1024. (DEFUN DECLARE-BOX-BORDERS-FN-PARAMETERS (BOX-TYPE TYPE-LABEL-STRING
  1025.                       &OPTIONAL (TYPE-LABEL-FONT-NO 1)
  1026.                             (TYPE-LABEL-INDENTATION 5)
  1027.                             (BORDER-WID 1)
  1028.                             (BORDER-SPA 1)
  1029.                             (NAME-BORDER-SPA 1)
  1030.                             (NAME-BORDER-WID 1)
  1031.                             (NAME-HIGHLIGHT T))
  1032.   (BOX-BORDERS-FN-SET-TYPE-LABEL-STRING BOX-TYPE TYPE-LABEL-STRING)
  1033.   (BOX-BORDERS-FN-SET-TYPE-LABEL-FONT-NO BOX-TYPE TYPE-LABEL-FONT-NO)
  1034.   (BOX-BORDERS-FN-SET-TYPE-LABEL-INDENTATION BOX-TYPE TYPE-LABEL-INDENTATION)
  1035.   (BOX-BORDERS-FN-SET-BORDER-WID BOX-TYPE BORDER-WID)
  1036.   (BOX-BORDERS-FN-SET-BORDER-SPA BOX-TYPE BORDER-SPA)
  1037.   (BOX-BORDERS-FN-SET-NAME-BORDER-WID BOX-TYPE NAME-BORDER-WID)
  1038.   (BOX-BORDERS-FN-SET-NAME-BORDER-SPA BOX-TYPE NAME-BORDER-SPA)
  1039.   (BOX-BORDERS-FN-SET-NAME-HIGHLIGHT  BOX-TYPE NAME-HIGHLIGHT))
  1040.  
  1041. (DECLARE-BOX-BORDERS-FN-PARAMETERS :DOIT-BOX "")
  1042. (DECLARE-BOX-BORDERS-FN-PARAMETERS :DATA-BOX "Data")
  1043. (DECLARE-BOX-BORDERS-FN-PARAMETERS :LL-BOX "Local Library")
  1044. (DECLARE-BOX-BORDERS-FN-PARAMETERS :PORT-BOX "Port")
  1045. (DECLARE-BOX-BORDERS-FN-PARAMETERS :GRAPHICS-BOX "Graphics")
  1046. (DECLARE-BOX-BORDERS-FN-PARAMETERS :GRAPHICS-DATA-BOX "Graphics Data")
  1047. (DECLARE-BOX-BORDERS-FN-PARAMETERS :SPRITE-BOX "Sprite")
  1048. (DECLARE-BOX-BORDERS-FN-PARAMETERS :INPUT-BOX "Input")
  1049.  
  1050. (DEFSELECT (BOX-BORDERS-FN)
  1051.   (:MINIMUM-SIZE . BOX-BORDERS-FN-MINIMUM-SIZE)
  1052.   (:BORDER-WIDS . BOX-BORDERS-FN-BORDER-WIDS)
  1053.   (:DRAW . BOX-BORDERS-FN-DRAW)
  1054.   (:CHANGE-SIZE . BOX-BORDERS-FN-CHANGE-SIZE)
  1055.   (:CHANGE-SIZE-PASS-1 . BOX-BORDERS-FN-CHANGE-SIZE-PASS-1)
  1056.   (:CHANGE-SIZE-PASS-2 . BOX-BORDERS-FN-CHANGE-SIZE-PASS-2)
  1057.   (:CHANGE-NAME-PASS-1 . BOX-BORDERS-FN-CHANGE-NAME-PASS-1)
  1058.   (:CHANGE-NAME-PASS-2 . BOX-BORDERS-FN-CHANGE-NAME-PASS-2)
  1059.   (:ZOOM . BOX-BORDERS-FN-ZOOM)
  1060.   (:TAB-SIZE . BOX-BORDERS-FN-NAME-TAB-SIZE)
  1061.   (:TAB-SPACE . BOX-BORDERS-FN-NAME-TAB-SPACE)
  1062.   (:TAB-OFFSETS . BOX-BORDERS-FN-NAME-TAB-OFFSETS))
  1063.  
  1064. (DEFUN SCREEN-BOX-BORDERS-FN (OP SCREEN-BOX &REST ARGS)
  1065.   (LEXPR-FUNCALL 'BOX-BORDERS-FN
  1066.           OP (TELL (SCREEN-OBJ-ACTUAL-OBJ SCREEN-BOX) :TYPE) SCREEN-BOX ARGS))
  1067.  
  1068. (DEFUN BOX-BORDERS-FN-NAME-TAB-SIZE (IGNORE BOX-TYPE SCREEN-BOX)
  1069.     (LET ((OUTER-WID 0) (OUTER-HEI 0) (X 0) (Y 0))
  1070.       (BOX-BORDERS-FN-BIND-INTERESTING-VALUES
  1071.     (IF (NULL SHOW-NAME-ROW)
  1072.         ;; there is no name row so it isn't going to have a size
  1073.         (VALUES 0 0)
  1074.         ;; otherwise the size will be...
  1075.         (BOX-BORDERS-FN-BIND-NAMED-BOX-PARAMETERS (NIL)
  1076.           (VALUES NAME-TAB-WID NAME-TAB-HEI))))))
  1077.  
  1078. (DEFUN BOX-BORDERS-FN-NAME-TAB-SPACE (IGNORE BOX-TYPE SCREEN-BOX)
  1079.     (LET ((OUTER-WID 0) (OUTER-HEI 0) (X 0) (Y 0))
  1080.       (BOX-BORDERS-FN-BIND-INTERESTING-VALUES
  1081.     (IF (NULL SHOW-NAME-ROW)
  1082.         ;; there is no name row so it isn't going to have a size
  1083.         (VALUES 0 0)
  1084.         ;; otherwise the size will be...
  1085.         (BOX-BORDERS-FN-BIND-NAMED-BOX-PARAMETERS (NIL)
  1086.           (VALUES (+ NAME-TAB-WID BORDER-SPA)
  1087.               (+ NAME-TAB-HEI BORDER-SPA
  1088.              (// (MAX 0 (- TYPE-LABEL-HEI BORDER-WID)) 2))))))))
  1089.  
  1090. (DEFUN BOX-BORDERS-FN-NAME-TAB-OFFSETS (IGNORE BOX-TYPE IGNORE &REST IGNORE)
  1091.   (BOX-BORDERS-FN-BIND-CONSTANT-VALUES
  1092.     ;; prevent bound but never used errors
  1093.     TYPE-LABEL-WID TYPE-LABEL-INDENTATION
  1094.     (VALUES (+ BORDER-SPA NAME-BORDER-WID NAME-BORDER-SPA)
  1095.         (+ BORDER-SPA (// (MAX 0 (- TYPE-LABEL-HEI BORDER-WID)) 2)
  1096.            NAME-BORDER-WID NAME-BORDER-SPA))))
  1097.  
  1098. (DEFUN BOX-BORDERS-FN-MINIMUM-SIZE (IGNORE BOX-TYPE SCREEN-BOX)
  1099.   (LET ((OUTER-WID 0) (OUTER-HEI 0) (X 0) (Y 0))
  1100.     (BOX-BORDERS-FN-BIND-INTERESTING-VALUES
  1101.       (IF (NULL SHOW-NAME-ROW)
  1102.       ;; There isn't a name row so we compute the box border parameters like we used to
  1103.       (BOX-BORDERS-FN-BIND-UNNAMED-BOX-PARAMETERS 
  1104.         (IF (EQ BOX-TYPE ':PORT-BOX)
  1105.         (VALUES (MAX *MINIMUM-BOX-WID*
  1106.                  (+ (* 2 *PORT-BOX-BORDER-GAP*)
  1107.                 (* 2 BORDER-SPA)
  1108.                 (* 4 BORDER-WID)
  1109.                 (* 2 TYPE-LABEL-INDENTATION)
  1110.                 TYPE-LABEL-WID))
  1111.             (MAX *MINIMUM-BOX-HEI*
  1112.                  (+ (* 2 *PORT-BOX-BORDER-GAP*)
  1113.                 (* 2 BORDER-SPA)
  1114.                 (* 4 BORDER-WID)
  1115.                 (// (MAX 0 (- TYPE-LABEL-HEI BORDER-WID)) 2))))
  1116.         (VALUES (MAX *MINIMUM-BOX-WID*
  1117.                  (+ (* 2 BORDER-SPA)
  1118.                 (* 2 BORDER-WID)
  1119.                 (* 2 TYPE-LABEL-INDENTATION)
  1120.                 TYPE-LABEL-WID))
  1121.             (MAX *MINIMUM-BOX-HEI*
  1122.                  (+ (* 2 BORDER-WID)
  1123.                 (* 2 BORDER-SPA)
  1124.                 (// (MAX 0 (- TYPE-LABEL-HEI BORDER-WID)) 2))))))
  1125.       ;; Otherwise, we have to deal with the name row's size
  1126.       (BOX-BORDERS-FN-BIND-NAMED-BOX-PARAMETERS (NIL)
  1127.         (IF (EQ BOX-TYPE ':PORT-BOX)
  1128.         (VALUES (MAX (+ NAME-TAB-WID *MINIMUM-BOX-WID*)
  1129.                  (+ NAME-TAB-WID
  1130.                 (* 2 *PORT-BOX-BORDER-GAP*)
  1131.                 (* 2 BORDER-SPA)
  1132.                 (* 4 BORDER-WID)
  1133.                 (* 2 TYPE-LABEL-INDENTATION)
  1134.                 TYPE-LABEL-WID))
  1135.             (MAX NAME-TAB-HEI
  1136.                  *MINIMUM-BOX-HEI*
  1137.                  (+ (* 2 *PORT-BOX-BORDER-GAP*)
  1138.                 (* 2 BORDER-SPA)
  1139.                 (* 4 BORDER-WID)
  1140.                 (// (MAX 0 (- TYPE-LABEL-HEI BORDER-WID)) 2))
  1141.                  (+ (* 2 BORDER-SPA)
  1142.                 NAME-TAB-HEI
  1143.                 (// (MAX 0 (- TYPE-LABEL-HEI BORDER-WID)) 2))))
  1144.         (VALUES (MAX (+ NAME-TAB-WID *MINIMUM-BOX-WID*)
  1145.                  (+ NAME-TAB-WID
  1146.                 (* 2 BORDER-SPA)
  1147.                 (* 2 BORDER-WID)
  1148.                 (* 2 TYPE-LABEL-INDENTATION)
  1149.                 TYPE-LABEL-WID))
  1150.             (MAX NAME-TAB-HEI
  1151.                  *MINIMUM-BOX-HEI*
  1152.                  (+ (* 2 BORDER-WID)
  1153.                 (* 2 BORDER-SPA)
  1154.                 (// (MAX 0 (- TYPE-LABEL-HEI BORDER-WID)) 2))
  1155.                  (+ (* 2 BORDER-SPA)
  1156.                 NAME-TAB-HEI
  1157.                 (// (MAX 0 (- TYPE-LABEL-HEI BORDER-WID)) 2))))))))))
  1158.  
  1159. (DEFUN BOX-BORDERS-FN-BORDER-WIDS (IGNORE BOX-TYPE SCREEN-BOX &OPTIONAL (OLD-P NIL))
  1160.   (LET ((OUTER-WID 0) (OUTER-HEI 0) (X 0) (Y 0))
  1161.     (BOX-BORDERS-FN-BIND-INTERESTING-VALUES
  1162.       (IF (NULL SHOW-NAME-ROW)
  1163.       ;; There isn't a name row so we compute the box border parameters like we used to
  1164.       (BOX-BORDERS-FN-BIND-UNNAMED-BOX-PARAMETERS
  1165.         (IF (EQ BOX-TYPE ':PORT-BOX)
  1166.         (VALUES  (+ (* 2 *PORT-BOX-BORDER-GAP*) (* 2 BORDER-WID))
  1167.              (+ (* 2 *PORT-BOX-BORDER-GAP*)
  1168.                 (MAX BORDER-WID TYPE-LABEL-HEI) BORDER-WID)
  1169.              (+ (* 2 *PORT-BOX-BORDER-GAP*)
  1170.                 (* 2 BORDER-WID))
  1171.              (+ (* 2 *PORT-BOX-BORDER-GAP*)
  1172.                 (* 2 BORDER-WID)))
  1173.         (VALUES  (+ (* 2 BORDER-SPA) BORDER-WID)
  1174.              (+ (* 2 BORDER-SPA) (MAX BORDER-WID TYPE-LABEL-HEI))
  1175.              (+ (* 2 BORDER-SPA) BORDER-WID)
  1176.              (+ (* 2 BORDER-SPA) BORDER-WID))))
  1177.       ;; Otherwise, we have to deal with the name row's size
  1178.       (BOX-BORDERS-FN-BIND-NAMED-BOX-PARAMETERS (OLD-P)
  1179.         (IF (EQ BOX-TYPE ':PORT-BOX)
  1180.         (VALUES (+ (* 2 *PORT-BOX-BORDER-GAP*) (* 2 BORDER-WID) NAME-TAB-WID)
  1181.             (+ (* 2 *PORT-BOX-BORDER-GAP*)
  1182.                (MAX BORDER-WID TYPE-LABEL-HEI) BORDER-WID)
  1183.             (+ (* 2 *PORT-BOX-BORDER-GAP*) (* 2 BORDER-WID))
  1184.             (+ (* 2 *PORT-BOX-BORDER-GAP*) (* 2 BORDER-WID)))
  1185.         (VALUES (+ (* 2 BORDER-SPA) BORDER-WID NAME-TAB-WID)
  1186.             (+ (* 2 BORDER-SPA) (MAX BORDER-WID TYPE-LABEL-HEI))
  1187.             (+ (* 2 BORDER-SPA) BORDER-WID)
  1188.             (+ (* 2 BORDER-SPA) BORDER-WID))))))))
  1189.  
  1190. (DEFUN BOX-BORDERS-FN-DRAW (IGNORE BOX-TYPE SCREEN-BOX OUTER-WID OUTER-HEI X Y
  1191.                 &OPTIONAL (OLD-P NIL) (NO-NAME-P NIL) (NO-TAB-P NIL))
  1192.   (OR (ZEROP OUTER-WID)
  1193.       (ZEROP OUTER-HEI)
  1194.       (BOX-BORDERS-FN-BIND-INTERESTING-VALUES
  1195.     (IF (AND (OR (NULL SHOW-NAME-ROW) NO-NAME-P)
  1196.          (NOT (AND OLD-P (TELL SCREEN-BOX :NAME))))
  1197.         ;; There isn't a name row so we draw the box borders like we used to
  1198.         (BOX-BORDERS-FN-BIND-UNNAMED-BOX-PARAMETERS
  1199.           (WITH-CLIPPING-INSIDE (X Y OUTER-WID OUTER-HEI)
  1200.         (LET ((*DRAW-CLIPPED-CHAS?* NIL))
  1201.           (DRAW-BOX-BORDERS))))
  1202.         ;; Looks like thers IS a name row so we have to do some extra work
  1203.         (BOX-BORDERS-FN-BIND-NAMED-BOX-PARAMETERS (OLD-P)
  1204.           (WITH-CLIPPING-INSIDE (X Y OUTER-WID OUTER-HEI)
  1205.         (UNLESS NO-TAB-P
  1206.           (DRAW-SCREEN-ROW-FOR-NAMING)
  1207.           (DRAW-NAME-BORDERS))
  1208.         (LET ((*DRAW-CLIPPED-CHAS?* NIL))
  1209.           (DRAW-BOX-BORDERS))))))))
  1210.  
  1211. (DEFUN BOX-BORDERS-FN-CHANGE-SIZE (IGNORE BOX-TYPE SCREEN-BOX
  1212.                    OLD-WID OLD-HEI NEW-WID NEW-HEI X Y)
  1213.   (BOX-BORDERS-FN ':DRAW BOX-TYPE SCREEN-BOX NEW-WID NEW-HEI X Y)
  1214.   (BOX-BORDERS-FN ':DRAW BOX-TYPE SCREEN-BOX OLD-WID OLD-HEI X Y T))
  1215.  
  1216. (DEFUN BOX-BORDERS-FN-CHANGE-SIZE-PASS-1 (IGNORE BOX-TYPE SCREEN-BOX
  1217.                       OLD-WID OLD-HEI IGNORE IGNORE X Y)
  1218.   (BOX-BORDERS-FN ':DRAW BOX-TYPE SCREEN-BOX OLD-WID OLD-HEI X Y T NIL T))
  1219.  
  1220. (DEFUN BOX-BORDERS-FN-CHANGE-SIZE-PASS-2 (IGNORE BOX-TYPE SCREEN-BOX
  1221.                       IGNORE IGNORE NEW-WID NEW-HEI X Y)
  1222.   (BOX-BORDERS-FN ':DRAW BOX-TYPE SCREEN-BOX NEW-WID NEW-HEI X Y NIL NIL T))
  1223.  
  1224. (DEFUN BOX-BORDERS-FN-CHANGE-NAME-PASS-1 (IGNORE BOX-TYPE SCREEN-BOX
  1225.                       OLD-WID OLD-HEI IGNORE IGNORE X Y)
  1226.   (IF (NULL (TELL SCREEN-BOX :NAME))
  1227.       (BOX-BORDERS-FN ':DRAW BOX-TYPE SCREEN-BOX OLD-WID OLD-HEI X Y T T)
  1228.       (BOX-BORDERS-FN ':DRAW BOX-TYPE SCREEN-BOX OLD-WID OLD-HEI X Y T)))
  1229.  
  1230. (DEFUN BOX-BORDERS-FN-CHANGE-NAME-PASS-2 (IGNORE BOX-TYPE SCREEN-BOX
  1231.                       IGNORE IGNORE NEW-WID NEW-HEI X Y)
  1232.   (IF (NULL (TELL (TELL SCREEN-BOX :ACTUAL-OBJ) :NAME-ROW))
  1233.       (BOX-BORDERS-FN ':DRAW BOX-TYPE SCREEN-BOX NEW-WID NEW-HEI X Y NIL T)
  1234.       (BOX-BORDERS-FN ':DRAW BOX-TYPE SCREEN-BOX NEW-WID NEW-HEI X Y)))
  1235.  
  1236. (DEFUN BOX-BORDERS-FN-ZOOM (IGNORE BOX-TYPE SCREEN-BOX
  1237.                 START-WID START-HEI END-WID END-HEI
  1238.                 START-X START-Y END-X END-Y STEPS)
  1239.   (HACKS:WITH-REAL-TIME
  1240.     (MULTIPLE-VALUE-BIND (MIN-WID MIN-HEI)
  1241.     (BOX-BORDERS-FN ':MINIMUM-SIZE BOX-TYPE SCREEN-BOX)
  1242.       (MAXIMIZE START-WID MIN-WID)
  1243.       (MAXIMIZE START-HEI MIN-HEI)
  1244.       (MAXIMIZE END-WID MIN-WID)
  1245.       (MAXIMIZE END-HEI MIN-HEI)
  1246.       (LET* ((WID-INCREMENT (// (- END-WID START-WID) STEPS))
  1247.          (HEI-INCREMENT (// (- END-HEI START-HEI) STEPS))
  1248.          (X-INCREMENT (// (- END-X START-X) STEPS))
  1249.          (Y-INCREMENT (// (- END-Y START-Y) STEPS)))
  1250.     (DO ((I 0 (+ I 1))
  1251.          (WID START-WID (+ WID WID-INCREMENT))
  1252.          (HEI START-HEI (+ HEI HEI-INCREMENT))
  1253.          (X START-X (+ X X-INCREMENT))
  1254.          (Y START-Y (+ Y Y-INCREMENT)))
  1255.         ((>= I STEPS))
  1256.       (BOX-BORDERS-FN ':DRAW BOX-TYPE SCREEN-BOX WID HEI X Y NIL NIL T)
  1257.       (PROCESS-SLEEP *BOX-ZOOM-WAITING-TIME* "ZooM")
  1258.       (BOX-BORDERS-FN ':DRAW BOX-TYPE SCREEN-BOX WID HEI X Y NIL NIL T))))))
  1259.  
  1260.  
  1261.  
  1262. ;;; circular structure support
  1263.  
  1264. (DEFUN PORT-HAS-BEEN-DISPLAYED-ENOUGH? (PORT)
  1265.   (LET ((ENTRY (CDR (ASSQ PORT PORT-REDISPLAY-HISTORY))))
  1266.     (AND ENTRY ( ENTRY *PORT-REDISPLAY-DEPTH*))))
  1267.  
  1268. (DEFUN UPDATE-PORT-REDISPLAY-HISTORY (PORT)
  1269.   (LET ((ENTRY (ASSQ PORT PORT-REDISPLAY-HISTORY)))
  1270.     (IF (NULL ENTRY) (APPEND PORT-REDISPLAY-HISTORY (NCONS (CONS PORT 1)))
  1271.     (LET ((NEW-HISTORY (COPYLIST PORT-REDISPLAY-HISTORY)))
  1272.       (SETF (CDR (ASSQ PORT NEW-HISTORY)) (1+ (CDR ENTRY)))
  1273.       NEW-HISTORY))))
  1274.  
  1275. ;;; some styles...
  1276.  
  1277. (DEFINE-BOX-ELLIPSIS-STYLE BOX-ELLIPSIS-SOLID-LINES)
  1278.  
  1279. (DEFUN (:PROPERTY BOX-ELLIPSIS-SOLID-LINES DRAW-SELF) (X-COORD Y-COORD)
  1280.   (LOOP FOR X FROM X-COORD TO (+ X-COORD (// *BOX-ELLIPSIS-WID* 2.))
  1281.           BY (+ *BOX-ELLIPSIS-THICKNESS* *BOX-ELLIPSIS-SPACING*)
  1282.     FOR Y FROM Y-COORD TO (+ Y-COORD (// *BOX-ELLIPSIS-WID* 2.))
  1283.           BY (+ *BOX-ELLIPSIS-THICKNESS* *BOX-ELLIPSIS-SPACING*)
  1284.     FOR WID FROM (- *BOX-ELLIPSIS-WID* (* 2 *BOX-ELLIPSIS-THICKNESS*)) DOWNTO 0
  1285.         BY (* 2 (+ *BOX-ELLIPSIS-THICKNESS* *BOX-ELLIPSIS-SPACING*))
  1286.     FOR HEI FROM *BOX-ELLIPSIS-HEI* DOWNTO 0
  1287.         BY (* 2 (+ *BOX-ELLIPSIS-THICKNESS* *BOX-ELLIPSIS-SPACING*))
  1288.     DO (DRAW-RECTANGLE TV:ALU-XOR *BOX-ELLIPSIS-THICKNESS* HEI X Y)
  1289.        (DRAW-RECTANGLE TV:ALU-XOR WID *BOX-ELLIPSIS-THICKNESS*
  1290.                (+ X *BOX-ELLIPSIS-THICKNESS*) Y)
  1291.        (DRAW-RECTANGLE TV:ALU-XOR *BOX-ELLIPSIS-THICKNESS* HEI
  1292.                (+ X WID *BOX-ELLIPSIS-THICKNESS*) Y)
  1293.        (DRAW-RECTANGLE TV:ALU-XOR WID *BOX-ELLIPSIS-THICKNESS*
  1294.                (+ X *BOX-ELLIPSIS-THICKNESS*)
  1295.                (+ Y HEI (- *BOX-ELLIPSIS-THICKNESS*)))))
  1296.  
  1297. (DEFINE-BOX-ELLIPSIS-STYLE BOX-ELLIPSIS-CORNER-DOTS)
  1298.  
  1299. (DEFUN (:PROPERTY BOX-ELLIPSIS-CORNER-DOTS DRAW-SELF) (X-COORD Y-COORD)
  1300.   (LOOP FOR X FROM X-COORD TO (+ X-COORD (// *BOX-ELLIPSIS-WID* 2.))
  1301.           BY (+ *BOX-ELLIPSIS-THICKNESS* *BOX-ELLIPSIS-SPACING*)
  1302.     FOR Y FROM Y-COORD TO (+ Y-COORD (// *BOX-ELLIPSIS-WID* 2.))
  1303.           BY (+ *BOX-ELLIPSIS-THICKNESS* *BOX-ELLIPSIS-SPACING*)
  1304.     FOR WID FROM (- *BOX-ELLIPSIS-WID* (* 2 *BOX-ELLIPSIS-THICKNESS*)) DOWNTO 0
  1305.         BY (* 2 (+ *BOX-ELLIPSIS-THICKNESS* *BOX-ELLIPSIS-SPACING*))
  1306.     FOR HEI FROM *BOX-ELLIPSIS-HEI* DOWNTO 0
  1307.         BY (* 2 (+ *BOX-ELLIPSIS-THICKNESS* *BOX-ELLIPSIS-SPACING*))
  1308.     DO (DRAW-RECTANGLE TV:ALU-XOR *BOX-ELLIPSIS-THICKNESS* *BOX-ELLIPSIS-THICKNESS* X Y)
  1309.        (DRAW-RECTANGLE TV:ALU-XOR *BOX-ELLIPSIS-THICKNESS* *BOX-ELLIPSIS-THICKNESS*
  1310.                (+ X WID *BOX-ELLIPSIS-THICKNESS*) Y)
  1311.        (DRAW-RECTANGLE TV:ALU-XOR *BOX-ELLIPSIS-THICKNESS* *BOX-ELLIPSIS-THICKNESS*
  1312.                X (+ Y HEI (- *BOX-ELLIPSIS-THICKNESS*)))
  1313.        (DRAW-RECTANGLE TV:ALU-XOR *BOX-ELLIPSIS-THICKNESS* *BOX-ELLIPSIS-THICKNESS*
  1314.                (+ X WID *BOX-ELLIPSIS-THICKNESS*)
  1315.                (+ Y HEI (- *BOX-ELLIPSIS-THICKNESS*)))))
  1316.  
  1317.  
  1318. ;;; Region marking stuff OBSOLETE !!!!!!
  1319. ;;; These1 will only0 work for regions that are1 single0 screen rows
  1320.  
  1321. ;;; updated versions. keep around for old code to use
  1322. (DEFUN MARK-ROW (ROW)
  1323.   (LET ((START-BP (MAKE-BP ':FIXED))
  1324.     (STOP-BP (MAKE-BP ':FIXED)))
  1325.     (SET-BP-ROW START-BP ROW)
  1326.     (SET-BP-CHA-NO START-BP 0)
  1327.     (SET-BP-ROW STOP-BP ROW)
  1328.     (SET-BP-CHA-NO STOP-BP (TELL ROW :LENGTH-IN-CHAS))
  1329.     (let ((region (MAKE-EDITOR-REGION START-BP STOP-BP)))
  1330.       (TELL REGION :TURN-ON)
  1331.       (PUSH REGION REGION-LIST))))
  1332.  
  1333. (DEFUN UNMARK-ROW (ROW)
  1334.   ;; first find the region
  1335.   (let ((region (mem #'(lambda (x y) (eq x (car(tell y :get-rows-from-bps))))
  1336.              row region-list)))
  1337.     (when (not-null region)
  1338.       (flush-region (car region)))))
  1339.  
  1340. ;(DEFVAR REGIONS NIL)
  1341. ;
  1342. ;(DEFVAR *CURRENT-SCREEN-REGION* NIL
  1343. ;  "The screen structure corresponding to the current region. ")
  1344. ;
  1345. ;(DEFFLAVOR REGION
  1346. ;    ((UID NIL))
  1347. ;    (TV:RECTANGULAR-BLINKER FLAVOR-HACKING-MIXIN)
  1348. ;  (:OUTSIDE-ACCESSIBLE-INSTANCE-VARIABLES UID))
  1349. ;
  1350. ;(DEFTYPE-CHECKING-MACROS REGION "A Boxer Editor Region Blinker")
  1351. ;
  1352. ;(DEFMETHOD (REGION :BLINK) ()
  1353. ;  (DRAWING-ON-WINDOW-WITHOUT-PREPARE-SHEET (TV:SHEET)
  1354. ;    (DRAW-RECTANGLE TV:ALU-XOR TV:WIDTH TV:HEIGHT TV:X-POS TV:Y-POS)))
  1355. ;
  1356. ;(DEFUN MAKE-REGION (UID WINDOW)
  1357. ;  (LET ((NEW-REGION (TV:MAKE-BLINKER WINDOW 'REGION ':VISIBILITY NIL ':FOLLOW-P NIL)))
  1358. ;    (SETF (REGION-UID NEW-REGION) UID)
  1359. ;    (PUSH NEW-REGION REGIONS)
  1360. ;    NEW-REGION))
  1361. ;
  1362. ;(DEFUN MARK-REGION (WINDOW UID VISIBILITY &OPTIONAL WID HEI X Y)
  1363. ;  (LET ((REGION (OR (CAR (MEM #'(LAMBDA (UID REG) (EQ UID (REGION-UID REG))) UID REGIONS))
  1364. ;            (MAKE-REGION UID WINDOW))))
  1365. ;    (ALTERING-REGION (REGION)
  1366. ;      (IF WID (SETF (REGION-WID REGION) WID))
  1367. ;      (IF HEI (SETF (REGION-HEI REGION) HEI))
  1368. ;      (IF X   (SETF (REGION-X REGION) X))
  1369. ;      (IF Y   (SETF (REGION-Y REGION) Y))
  1370. ;      (SETF (REGION-VISIBILITY REGION) VISIBILITY))))
  1371.  
  1372. ;(DEFUN MARK-CURRENT-REGION (ROW)
  1373. ;  (COND ((NULL ROW)
  1374. ;     (UNMARK-SCREEN-ROW *CURRENT-SCREEN-REGION*)
  1375. ;     (SETQ *CURRENT-SCREEN-REGION* NIL))
  1376. ;    (T
  1377. ;     (LET ((SCREEN-ROW (CURRENT-SCREEN-ROW ROW)))
  1378. ;       (MULTIPLE-VALUE-BIND (X Y)
  1379. ;           (TELL SCREEN-ROW :POSITION)
  1380. ;         (LET ((WID (SCREEN-OBJ-WID SCREEN-ROW))
  1381. ;           (HEI (SCREEN-OBJ-HEI SCREEN-ROW)))
  1382. ;           (MARK-REGION *BOXER-PANE* SCREEN-ROW T WID HEI X Y)))
  1383. ;       (SETQ *CURRENT-SCREEN-REGION* SCREEN-ROW)))))
  1384. ;
  1385. ;(DEFUN MARK-SCREEN-ROW (SCREEN-ROW)
  1386. ;  (CHECK-SCREEN-ROW-ARG SCREEN-ROW)
  1387. ;  (MULTIPLE-VALUE-BIND (X Y)
  1388. ;      (TELL SCREEN-ROW :POSITION)
  1389. ;    (LET ((WID (SCREEN-OBJ-WID SCREEN-ROW))
  1390. ;      (HEI (SCREEN-OBJ-HEI SCREEN-ROW)))
  1391. ;      (MARK-REGION *BOXER-PANE* SCREEN-ROW T WID HEI X Y))))
  1392. ;
  1393. ;(DEFUN FIND-ROW-BLINKER (SCREEN-ROW LIST-OF-REGIONS)
  1394. ;  (DOLIST (REGION LIST-OF-REGIONS)
  1395. ;    (WHEN (REGION? REGION)
  1396. ;      (WHEN (EQ SCREEN-ROW (REGION-UID REGION))
  1397. ;    (RETURN REGION)))))
  1398. ;        
  1399. ;(DEFUN REMOVE-ROW-BLINKER (SCREEN-ROW LIST-OF-REGIONS)
  1400. ;  (DELQ (FIND-ROW-BLINKER SCREEN-ROW LIST-OF-REGIONS)
  1401. ;       LIST-OF-REGIONS))
  1402. ;
  1403. ;(DEFUN UNMARK-SCREEN-ROW (SCREEN-ROW)
  1404. ;  (tell (find-row-blinker screen-row regions) :set-visibility nil)
  1405. ;  (SETF REGIONS (REMOVE-ROW-BLINKER SCREEN-ROW REGIONS))
  1406. ;  (SETF (TV:SHEET-BLINKER-LIST *BOXER-PANE*)
  1407. ;    (REMOVE-ROW-BLINKER SCREEN-ROW
  1408. ;                (TV:SHEET-BLINKER-LIST *BOXER-PANE*))))
  1409. ;
  1410. ;(DEFMETHOD (REGION :UPDATE) ()
  1411. ;  (IF (TELL UID :VISIBLE?)
  1412. ;      (UPDATE-ROW-BLINKER SELF UID)
  1413. ;      ;(SHRINK-ROW-BLINKER SELF)
  1414. ;      (UNMARK-SCREEN-ROW UID)))
  1415. ;
  1416. ;(DEFUN UPDATE-ROW-BLINKER (OLD-REGION SCREEN-ROW)
  1417. ;  (ALTERING-REGION (OLD-REGION)
  1418. ;    (MULTIPLE-VALUE-BIND (X Y)
  1419. ;    (TELL SCREEN-ROW :POSITION)
  1420. ;      (LET ((WID (SCREEN-OBJ-WID SCREEN-ROW))
  1421. ;        (HEI (SCREEN-OBJ-HEI SCREEN-ROW)))
  1422. ;    (SETF (REGION-WID OLD-REGION) WID)
  1423. ;    (SETF (REGION-HEI OLD-REGION) HEI)
  1424. ;    (SETF (REGION-X OLD-REGION) X)
  1425. ;    (SETF (REGION-Y OLD-REGION) Y)))))
  1426. ;
  1427. ;(DEFUN SHRINK-ROW-BLINKER (REGION)
  1428. ;  (ALTERING-REGION (REGION)
  1429. ;    (SETF (REGION-WID REGION) 0)
  1430. ;    (SETF (REGION-HEI REGION) 0)
  1431. ;    (SETF (REGION-VISIBILITY REGION) NIL)))
  1432.  
  1433. ;(DEFUN UPDATE-ACTUAL-ROW-BLINKER (ROW)
  1434. ;  (UPDATE-ROW-BLINKER (CAR (TELL ROW :DISPLAYED-SCREEN-OBJS))))
  1435. ;
  1436. ;(DEFUN UPDATE-REGION (REGION)
  1437. ;  (CHECK-REGION-ARG REGION)
  1438. ;  (TELL REGION :UPDATE))
  1439. ;
  1440. ;(DEFUN UNMARK-ALL-ROWS ()            ;this does not unmark the *current-region*
  1441. ;  (DOLIST (REGION REGIONS)
  1442. ;    (UNLESS (EQ (REGION-UID REGION) *CURRENT-SCREEN-REGION*)
  1443. ;      (UNMARK-SCREEN-ROW (REGION-UID REGION)))))
  1444.